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

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

10 11
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
12
Software Foundation; either version 3, or (at your option) any later
13
version.
dnovillo's avatar
 
dnovillo committed
14

15 16 17 18
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
19 20

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

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

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
30
#include "diagnostic-core.h"	/* For fatal_error.  */
fxcoudert's avatar
fxcoudert committed
31
#include "langhooks.h"
dnovillo's avatar
 
dnovillo committed
32 33
#include "flags.h"
#include "gfortran.h"
34
#include "arith.h"
35
#include "constructor.h"
dnovillo's avatar
 
dnovillo committed
36 37 38 39 40 41
#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
42
#include "dependency.h"
dnovillo's avatar
 
dnovillo committed
43

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

/* 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;
}


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

   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
79
   se->ss = se->ss->next because all the parents needs to be kept in sync.
dnovillo's avatar
 
dnovillo committed
80 81 82 83 84 85 86
   See gfc_init_se.  */

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

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

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

      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;

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

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


121 122
/* 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
123 124 125 126

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

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

  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
136
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
dnovillo's avatar
 
dnovillo committed
137 138 139
             || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    }
140

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

  /* 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);
154 155 156 157
      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);
158 159 160
    }

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


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

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

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

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

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


208 209 210 211 212 213 214 215 216 217 218 219 220 221
/* 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.  */

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

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

  /* 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)
244
	    length = r->u.c.component->ts.u.cl->backend_decl;
245 246 247 248 249 250 251 252 253 254
	  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 ();
255
	  break;
256 257 258 259 260 261 262
	}
    }

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

domob's avatar
domob committed
263

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
/* Return for an expression the backend decl of the coarray.  */

static tree
get_tree_for_caf_expr (gfc_expr *expr)
{
   tree caf_decl = NULL_TREE;
   gfc_ref *ref;

   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
   if (expr->symtree->n.sym->attr.codimension)
     caf_decl = expr->symtree->n.sym->backend_decl;

   for (ref = expr->ref; ref; ref = ref->next)
     if (ref->type == REF_COMPONENT)
       {
	gfc_component *comp = ref->u.c.component;
        if (comp->attr.pointer || comp->attr.allocatable)
	  caf_decl = NULL_TREE;
	if (comp->attr.codimension)
	  caf_decl = comp->backend_decl;
       }

   gcc_assert (caf_decl != NULL_TREE);
   return caf_decl;
}


291
/* For each character array constructor subexpression without a ts.u.cl->length,
domob's avatar
domob committed
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
   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.  */
324
      if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
domob's avatar
domob committed
325
	{
326
	  gfc_constructor *c;
domob's avatar
domob committed
327
	  gfc_expr* new_expr;
328

domob's avatar
domob committed
329 330
	  gcc_assert (e->value.constructor);

331 332 333
	  c = gfc_constructor_first (e->value.constructor);
	  new_expr = c->expr;
	  c->expr = NULL;
domob's avatar
domob committed
334 335 336 337 338 339 340 341

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

      /* Otherwise, fall through to handle constructor elements.  */
    case EXPR_STRUCTURE:
342 343
      for (c = gfc_constructor_first (e->value.constructor);
	   c; c = gfc_constructor_next (c))
domob's avatar
domob committed
344 345 346 347 348 349 350 351 352
	flatten_array_ctors_without_strlen (c->expr);
      break;

    default:
      break;

    }
}

353

dnovillo's avatar
 
dnovillo committed
354
/* Generate code to initialize a string length variable. Returns the
domob's avatar
domob committed
355 356 357
   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
358 359

void
domob's avatar
domob committed
360
gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
dnovillo's avatar
 
dnovillo committed
361 362 363 364
{
  gfc_se se;

  gfc_init_se (&se, NULL);
domob's avatar
domob committed
365

366 367 368 369 370
  if (!cl->length
	&& cl->backend_decl
	&& TREE_CODE (cl->backend_decl) == VAR_DECL)
    return;

domob's avatar
domob committed
371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
  /* 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
394
  gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
395 396
  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
397 398
  gfc_add_block_to_block (pblock, &se.pre);

399
  if (cl->backend_decl)
400
    gfc_add_modify (pblock, cl->backend_decl, se.expr);
401 402
  else
    cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
dnovillo's avatar
 
dnovillo committed
403 404
}

405

dnovillo's avatar
 
dnovillo committed
406
static void
burnus's avatar
burnus committed
407 408
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
		    const char *name, locus *where)
dnovillo's avatar
 
dnovillo committed
409 410 411
{
  tree tmp;
  tree type;
burnus's avatar
burnus committed
412
  tree fault;
dnovillo's avatar
 
dnovillo committed
413 414
  gfc_se start;
  gfc_se end;
burnus's avatar
burnus committed
415
  char *msg;
dnovillo's avatar
 
dnovillo committed
416 417 418 419 420

  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
421
  gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
dnovillo's avatar
 
dnovillo committed
422 423 424
  gfc_add_block_to_block (&se->pre, &start.pre);

  if (integer_onep (start.expr))
425
    gfc_conv_string_parameter (se);
dnovillo's avatar
 
dnovillo committed
426 427
  else
    {
428 429
      tmp = start.expr;
      STRIP_NOPS (tmp);
fxcoudert's avatar
fxcoudert committed
430
      /* Avoid multiple evaluation of substring start.  */
431
      if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
fxcoudert's avatar
fxcoudert committed
432 433
	start.expr = gfc_evaluate_now (start.expr, &se->pre);

dnovillo's avatar
 
dnovillo committed
434 435 436 437
      /* Change the start of the string.  */
      if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
	tmp = se->expr;
      else
438 439
	tmp = build_fold_indirect_ref_loc (input_location,
				       se->expr);
440
      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
dnovillo's avatar
 
dnovillo committed
441 442 443 444 445 446 447 448 449
      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
450
      gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
dnovillo's avatar
 
dnovillo committed
451 452
      gfc_add_block_to_block (&se->pre, &end.pre);
    }
453 454 455
  tmp = end.expr;
  STRIP_NOPS (tmp);
  if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
fxcoudert's avatar
fxcoudert committed
456 457
    end.expr = gfc_evaluate_now (end.expr, &se->pre);

458
  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
burnus's avatar
burnus committed
459
    {
460 461 462
      tree nonempty = fold_build2_loc (input_location, LE_EXPR,
				       boolean_type_node, start.expr,
				       end.expr);
tobi's avatar
tobi committed
463

burnus's avatar
burnus committed
464
      /* Check lower bound.  */
465 466 467 468 469
      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
470
      if (name)
fxcoudert's avatar
fxcoudert committed
471
	asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
burnus's avatar
burnus committed
472 473
		  "is less than one", name);
      else
fxcoudert's avatar
fxcoudert committed
474
	asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
burnus's avatar
burnus committed
475
		  "is less than one");
476
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fxcoudert's avatar
fxcoudert committed
477 478
			       fold_convert (long_integer_type_node,
					     start.expr));
479
      free (msg);
burnus's avatar
burnus committed
480 481

      /* Check upper bound.  */
482 483 484 485
      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
486
      if (name)
fxcoudert's avatar
fxcoudert committed
487 488
	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
		  "exceeds string length (%%ld)", name);
burnus's avatar
burnus committed
489
      else
fxcoudert's avatar
fxcoudert committed
490 491
	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
		  "exceeds string length (%%ld)");
492
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fxcoudert's avatar
fxcoudert committed
493 494 495
			       fold_convert (long_integer_type_node, end.expr),
			       fold_convert (long_integer_type_node,
					     se->string_length));
496
      free (msg);
burnus's avatar
burnus committed
497 498
    }

499 500 501 502 503 504 505 506 507 508 509 510 511 512
  /* 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));
    }

513
  se->string_length = tmp;
dnovillo's avatar
 
dnovillo committed
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528
}


/* 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
529
  gcc_assert (c->backend_decl);
dnovillo's avatar
 
dnovillo committed
530 531

  field = c->backend_decl;
pbrook's avatar
pbrook committed
532
  gcc_assert (TREE_CODE (field) == FIELD_DECL);
dnovillo's avatar
 
dnovillo committed
533
  decl = se->expr;
matz's avatar
matz committed
534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553

  /* Components can correspond to fields of different containing
     types, as components are created without context, whereas
     a concrete use of a component has the type of decl as context.
     So, if the type doesn't match, we search the corresponding
     FIELD_DECL in the parent type.  To not waste too much time
     we cache this result in norestrict_decl.  */

  if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
    {
      tree f2 = c->norestrict_decl;
      if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
	for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
	  if (TREE_CODE (f2) == FIELD_DECL
	      && DECL_NAME (f2) == DECL_NAME (field))
	    break;
      gcc_assert (f2);
      c->norestrict_decl = f2;
      field = f2;
    }
554 555
  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
			 decl, field, NULL_TREE);
dnovillo's avatar
 
dnovillo committed
556 557 558

  se->expr = tmp;

559
  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
dnovillo's avatar
 
dnovillo committed
560
    {
561
      tmp = c->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
562
      /* Components must always be constant length.  */
pbrook's avatar
pbrook committed
563
      gcc_assert (tmp && INTEGER_CST_P (tmp));
dnovillo's avatar
 
dnovillo committed
564 565 566
      se->string_length = tmp;
    }

567 568
  if (((c->attr.pointer || c->attr.allocatable)
       && (!c->attr.dimension && !c->attr.codimension)
burnus's avatar
burnus committed
569
       && c->ts.type != BT_CHARACTER)
570
      || c->attr.proc_pointer)
571 572
    se->expr = build_fold_indirect_ref_loc (input_location,
					se->expr);
dnovillo's avatar
 
dnovillo committed
573 574 575
}


pault's avatar
pault committed
576 577 578 579 580 581 582 583 584 585 586 587 588
/* 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;

589 590 591 592 593
  /* Return if the component is not in the parent type.  */
  for (cmp = dt->components; cmp; cmp = cmp->next)
    if (strcmp (c->name, cmp->name) == 0)
      return;

pault's avatar
pault committed
594 595 596 597 598 599
  /* 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;

600 601 602
  if (dt->backend_decl == NULL)
    gfc_get_derived_type (dt);

603 604 605 606 607
  /* Build the reference and call self.  */
  gfc_conv_component_ref (se, &parent);
  parent.u.c.sym = dt->components->ts.u.derived;
  parent.u.c.component = c;
  conv_parent_component_references (se, &parent);
pault's avatar
pault committed
608 609
}

dnovillo's avatar
 
dnovillo committed
610 611 612 613 614 615 616 617
/* 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;
618
  tree parent_decl = NULL_TREE;
619 620 621 622
  int parent_flag;
  bool return_value;
  bool alternate_entry;
  bool entry_master;
dnovillo's avatar
 
dnovillo committed
623 624 625 626 627

  sym = expr->symtree->n.sym;
  if (se->ss != NULL)
    {
      /* Check that something hasn't gone horribly wrong.  */
pbrook's avatar
pbrook committed
628 629
      gcc_assert (se->ss != gfc_ss_terminator);
      gcc_assert (se->ss->expr == expr);
dnovillo's avatar
 
dnovillo committed
630 631 632

      /* A scalarized term.  We already know the descriptor.  */
      se->expr = se->ss->data.info.descriptor;
pbrook's avatar
pbrook committed
633
      se->string_length = se->ss->string_length;
rsandifo's avatar
rsandifo committed
634 635 636
      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
637 638 639
    }
  else
    {
640 641
      tree se_expr = NULL_TREE;

642
      se->expr = gfc_get_symbol_decl (sym);
dnovillo's avatar
 
dnovillo committed
643

644 645 646 647
      /* 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
648
			&& sym->result == sym;
649
      entry_master = sym->attr.result
650 651
		     && sym->ns->proc_name->attr.entry_master
		     && !gfc_return_by_reference (sym->ns->proc_name);
652 653
      if (current_function_decl)
	parent_decl = DECL_CONTEXT (current_function_decl);
654 655

      if ((se->expr == parent_decl && return_value)
656
	   || (sym->ns && sym->ns->proc_name
657
	       && parent_decl
658 659
	       && sym->ns->proc_name->backend_decl == parent_decl
	       && (alternate_entry || entry_master)))
660 661 662 663
	parent_flag = 1;
      else
	parent_flag = 0;

664 665
      /* Special case for assigning the return value of a function.
	 Self recursive functions must have an explicit return value.  */
666
      if (return_value && (se->expr == current_function_decl || parent_flag))
667
	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
668 669

      /* Similarly for alternate entry points.  */
670
      else if (alternate_entry 
671 672
	       && (sym->ns->proc_name->backend_decl == current_function_decl
		   || parent_flag))
673 674 675 676 677 678
	{
	  gfc_entry_list *el = NULL;

	  for (el = sym->ns->entries; el; el = el->next)
	    if (sym == el->sym)
	      {
679
		se_expr = gfc_get_fake_result_decl (sym, parent_flag);
680 681 682 683
		break;
	      }
	}

684
      else if (entry_master
685 686
	       && (sym->ns->proc_name->backend_decl == current_function_decl
		   || parent_flag))
687
	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
688 689 690 691

      if (se_expr)
	se->expr = se_expr;

dnovillo's avatar
 
dnovillo committed
692
      /* Procedure actual arguments.  */
693 694
      else if (sym->attr.flavor == FL_PROCEDURE
	       && se->expr != current_function_decl)
dnovillo's avatar
 
dnovillo committed
695
	{
696
	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
dnovillo's avatar
 
dnovillo committed
697
	    {
pbrook's avatar
pbrook committed
698
	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
699
	      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
dnovillo's avatar
 
dnovillo committed
700 701
	    }
	  return;
kazu's avatar
kazu committed
702 703 704 705 706 707 708 709
	}


      /* Dereference the expression, where needed. Since characters
	 are entirely different from other types, they are treated 
	 separately.  */
      if (sym->ts.type == BT_CHARACTER)
	{
710
	  /* Dereference character pointer dummy arguments
711
	     or results.  */
kazu's avatar
kazu committed
712
	  if ((sym->attr.pointer || sym->attr.allocatable)
713 714 715
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result))
716 717
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
718

kazu's avatar
kazu committed
719
	}
720
      else if (!sym->attr.value)
kazu's avatar
kazu committed
721
	{
722 723 724
	  /* Dereference non-character scalar dummy arguments.  */
	  if (sym->attr.dummy && !sym->attr.dimension
	      && !(sym->attr.codimension && sym->attr.allocatable))
725 726
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
727

728
          /* Dereference scalar hidden result.  */
729
	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
kazu's avatar
kazu committed
730
	      && (sym->attr.function || sym->attr.result)
fxcoudert's avatar
fxcoudert committed
731 732
	      && !sym->attr.dimension && !sym->attr.pointer
	      && !sym->attr.always_explicit)
733 734
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
735

domob's avatar
domob committed
736
	  /* Dereference non-character pointer variables. 
kazu's avatar
kazu committed
737
	     These must be dummies, results, or scalars.  */
domob's avatar
domob committed
738 739
	  if ((sym->attr.pointer || sym->attr.allocatable
	       || gfc_is_associate_pointer (sym))
740 741 742
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result
743 744
		  || (!sym->attr.dimension
		      && (!sym->attr.codimension || !sym->attr.allocatable))))
745 746
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
747 748
	}

dnovillo's avatar
 
dnovillo committed
749 750 751 752 753 754
      ref = expr->ref;
    }

  /* For character variables, also get the length.  */
  if (sym->ts.type == BT_CHARACTER)
    {
eedelman's avatar
eedelman committed
755 756
      /* If the character length of an entry isn't set, get the length from
         the master function instead.  */
757 758
      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
759
      else
760
        se->string_length = sym->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
761
      gcc_assert (se->string_length);
dnovillo's avatar
 
dnovillo committed
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
    }

  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;

779
	  gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
dnovillo's avatar
 
dnovillo committed
780 781 782 783
	  /* Return a pointer to an element.  */
	  break;

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

dnovillo's avatar
 
dnovillo committed
787 788 789 790
	  gfc_conv_component_ref (se, ref);
	  break;

	case REF_SUBSTRING:
burnus's avatar
burnus committed
791 792
	  gfc_conv_substring (se, ref, expr->ts.kind,
			      expr->symtree->name, &expr->where);
dnovillo's avatar
 
dnovillo committed
793 794 795
	  break;

	default:
pbrook's avatar
pbrook committed
796
	  gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
797 798 799 800 801
	  break;
	}
      ref = ref->next;
    }
  /* Pointer assignment, allocation or pass by reference.  Arrays are handled
802
     separately.  */
dnovillo's avatar
 
dnovillo committed
803 804
  if (se->want_pointer)
    {
805
      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
dnovillo's avatar
 
dnovillo committed
806 807
	gfc_conv_string_parameter (se);
      else 
808
	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
dnovillo's avatar
 
dnovillo committed
809 810 811 812 813 814 815 816 817 818 819 820
    }
}


/* 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
821
  gcc_assert (expr->ts.type != BT_CHARACTER);
dnovillo's avatar
 
dnovillo committed
822 823
  /* Initialize the operand.  */
  gfc_init_se (&operand, se);
824
  gfc_conv_expr_val (&operand, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
825 826 827 828 829 830
  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)).
831
     All other unary operators have an equivalent GIMPLE unary operator.  */
dnovillo's avatar
 
dnovillo committed
832
  if (code == TRUTH_NOT_EXPR)
833 834
    se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
				build_int_cst (type, 0));
dnovillo's avatar
 
dnovillo committed
835
  else
836
    se->expr = fold_build1_loc (input_location, code, type, operand.expr);
dnovillo's avatar
 
dnovillo committed
837 838 839

}

840
/* Expand power operator to optimal multiplications when a value is raised
841
   to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
842 843 844 845 846 847 848 849 850 851
   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

852
/* The table is from builtins.c.  */
853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888
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 */
  };

889 890
/* If n is larger than lookup table's max index, we use the "window 
   method".  */
891 892
#define POWI_WINDOW_SIZE 3

893 894
/* Recursive function to expand the power operator. The temporary 
   values are put in tmpvar. The function returns tmpvar[1] ** n.  */
895
static tree
fxcoudert's avatar
fxcoudert committed
896
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
dnovillo's avatar
 
dnovillo committed
897
{
898 899
  tree op0;
  tree op1;
dnovillo's avatar
 
dnovillo committed
900
  tree tmp;
901
  int digit;
dnovillo's avatar
 
dnovillo committed
902

903
  if (n < POWI_TABLE_SIZE)
dnovillo's avatar
 
dnovillo committed
904
    {
905 906
      if (tmpvar[n])
        return tmpvar[n];
dnovillo's avatar
 
dnovillo committed
907

908 909 910 911 912 913 914 915
      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
916 917 918
    }
  else
    {
919 920
      op0 = gfc_conv_powi (se, n >> 1, tmpvar);
      op1 = op0;
dnovillo's avatar
 
dnovillo committed
921 922
    }

923
  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
924
  tmp = gfc_evaluate_now (tmp, &se->pre);
dnovillo's avatar
 
dnovillo committed
925

926 927
  if (n < POWI_TABLE_SIZE)
    tmpvar[n] = tmp;
dnovillo's avatar
 
dnovillo committed
928

929 930
  return tmp;
}
dnovillo's avatar
 
dnovillo committed
931

932 933 934 935

/* 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.  */
936 937 938 939 940 941 942
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
943 944
  HOST_WIDE_INT m;
  unsigned HOST_WIDE_INT n;
945
  int sgn;
dnovillo's avatar
 
dnovillo committed
946

fxcoudert's avatar
fxcoudert committed
947 948 949 950 951 952 953 954 955 956
  /* 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);
  
957 958
  type = TREE_TYPE (lhs);
  sgn = tree_int_cst_sgn (rhs);
dnovillo's avatar
 
dnovillo committed
959

fxcoudert's avatar
fxcoudert committed
960 961
  if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
       || optimize_size) && (m > 2 || m < -1))
962
    return 0;
dnovillo's avatar
 
dnovillo committed
963

964 965 966 967 968 969
  /* rhs == 0  */
  if (sgn == 0)
    {
      se->expr = gfc_build_const (type, integer_one_node);
      return 1;
    }
fxcoudert's avatar
fxcoudert committed
970

971 972 973
  /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
  if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
    {
974 975 976 977
      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));
978

979
      /* If rhs is even,
980
	 result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
981 982
      if ((n & 1) == 0)
        {
983 984 985 986 987
	  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));
988 989
	  return 1;
	}
990
      /* If rhs is odd,
991
	 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
992 993 994 995 996
      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);
997 998
      return 1;
    }
dnovillo's avatar
 
dnovillo committed
999

1000 1001 1002 1003 1004
  memset (vartmp, 0, sizeof (vartmp));
  vartmp[1] = lhs;
  if (sgn == -1)
    {
      tmp = gfc_build_const (type, integer_one_node);
1005 1006
      vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
				   vartmp[1]);
1007
    }
1008 1009 1010

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

1011
  return 1;
dnovillo's avatar
 
dnovillo committed
1012 1013 1014
}


1015
/* Power op (**).  Constant integer exponent has special handling.  */
dnovillo's avatar
 
dnovillo committed
1016 1017 1018 1019

static void
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
{
1020
  tree gfc_int4_type_node;
dnovillo's avatar
 
dnovillo committed
1021
  int kind;
1022
  int ikind;
domob's avatar
domob committed
1023
  int res_ikind_1, res_ikind_2;
dnovillo's avatar
 
dnovillo committed
1024 1025
  gfc_se lse;
  gfc_se rse;
1026
  tree fndecl = NULL;
dnovillo's avatar
 
dnovillo committed
1027 1028

  gfc_init_se (&lse, se);
1029
  gfc_conv_expr_val (&lse, expr->value.op.op1);
1030
  lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
dnovillo's avatar
 
dnovillo committed
1031 1032 1033
  gfc_add_block_to_block (&se->pre, &lse.pre);

  gfc_init_se (&rse, se);
1034
  gfc_conv_expr_val (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
1035 1036
  gfc_add_block_to_block (&se->pre, &rse.pre);

1037
  if (expr->value.op.op2->ts.type == BT_INTEGER
jb's avatar
jb committed
1038
      && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1039
    if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
jb's avatar
jb committed
1040
      return;
dnovillo's avatar
 
dnovillo committed
1041

1042 1043
  gfc_int4_type_node = gfc_get_int_type (4);

domob's avatar
domob committed
1044 1045 1046 1047 1048 1049 1050
  /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
     library routine.  But in the end, we have to convert the result back
     if this case applies -- with res_ikind_K, we keep track whether operand K
     falls into this case.  */
  res_ikind_1 = -1;
  res_ikind_2 = -1;

1051 1052
  kind = expr->value.op.op1->ts.kind;
  switch (expr->value.op.op2->ts.type)
dnovillo's avatar
 
dnovillo committed
1053 1054
    {
    case BT_INTEGER:
1055
      ikind = expr->value.op.op2->ts.kind;
1056 1057 1058 1059 1060
      switch (ikind)
	{
	case 1:
	case 2:
	  rse.expr = convert (gfc_int4_type_node, rse.expr);
domob's avatar
domob committed
1061
	  res_ikind_2 = ikind;
1062 1063 1064 1065 1066 1067 1068 1069 1070 1071
	  /* Fall through.  */

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

fxcoudert's avatar
fxcoudert committed
1072 1073 1074 1075
	case 16:
	  ikind = 2;
	  break;

1076
	default:
pbrook's avatar
pbrook committed
1077
	  gcc_unreachable ();
1078 1079 1080 1081 1082
	}
      switch (kind)
	{
	case 1:
	case 2:
1083
	  if (expr->value.op.op1->ts.type == BT_INTEGER)
domob's avatar
domob committed
1084 1085 1086 1087
	    {
	      lse.expr = convert (gfc_int4_type_node, lse.expr);
	      res_ikind_1 = kind;
	    }
1088
	  else
pbrook's avatar
pbrook committed
1089
	    gcc_unreachable ();
1090 1091 1092 1093 1094 1095 1096 1097 1098 1099
	  /* Fall through.  */

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

fxcoudert's avatar
fxcoudert committed
1100 1101 1102 1103 1104 1105 1106 1107
	case 10:
	  kind = 2;
	  break;

	case 16:
	  kind = 3;
	  break;

1108
	default:
pbrook's avatar
pbrook committed
1109
	  gcc_unreachable ();
1110 1111
	}
      
1112
      switch (expr->value.op.op1->ts.type)
1113 1114
	{
	case BT_INTEGER:
fxcoudert's avatar
fxcoudert committed
1115 1116
	  if (kind == 3) /* Case 16 was not handled properly above.  */
	    kind = 2;
1117 1118 1119 1120
	  fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
	  break;

	case BT_REAL:
jb's avatar
jb committed
1121 1122 1123 1124 1125 1126
	  /* Use builtins for real ** int4.  */
	  if (ikind == 0)
	    {
	      switch (kind)
		{
		case 0:
1127
		  fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
jb's avatar
jb committed
1128 1129 1130
		  break;
		
		case 1:
1131
		  fndecl = builtin_decl_explicit (BUILT_IN_POWI);
jb's avatar
jb committed
1132 1133 1134
		  break;

		case 2:
1135
		  fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
jb's avatar
jb committed
1136 1137
		  break;

1138 1139 1140 1141
		case 3:
		  /* Use the __builtin_powil() only if real(kind=16) is 
		     actually the C long double type.  */
		  if (!gfc_real16_is_float128)
1142
		    fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1143 1144
		  break;

jb's avatar
jb committed
1145 1146 1147 1148
		default:
		  gcc_unreachable ();
		}
	    }
1149 1150 1151 1152

	  /* If we don't have a good builtin for this, go for the 
	     library function.  */
	  if (!fndecl)
jb's avatar
jb committed
1153
	    fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1154 1155 1156 1157 1158 1159 1160
	  break;

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

	default:
pbrook's avatar
pbrook committed
1161
	  gcc_unreachable ();
1162 1163
 	}
      break;
dnovillo's avatar
 
dnovillo committed
1164 1165

    case BT_REAL:
1166
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
dnovillo's avatar
 
dnovillo committed
1167 1168 1169
      break;

    case BT_COMPLEX:
1170
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
dnovillo's avatar
 
dnovillo committed
1171 1172 1173
      break;

    default:
pbrook's avatar
pbrook committed
1174
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
1175 1176 1177
      break;
    }

1178 1179
  se->expr = build_call_expr_loc (input_location,
			      fndecl, 2, lse.expr, rse.expr);
domob's avatar
domob committed
1180 1181 1182 1183 1184 1185 1186 1187 1188

  /* Convert the result back if it is of wrong integer kind.  */
  if (res_ikind_1 != -1 && res_ikind_2 != -1)
    {
      /* We want the maximum of both operand kinds as result.  */
      if (res_ikind_1 < res_ikind_2)
	res_ikind_1 = res_ikind_2;
      se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
    }
dnovillo's avatar
 
dnovillo committed
1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202
}


/* 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.  */
1203 1204 1205
      tmp = fold_build2_loc (input_location, MINUS_EXPR,
			     gfc_charlen_type_node, len,
			     build_int_cst (gfc_charlen_type_node, 1));
1206
      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
fxcoudert's avatar
fxcoudert committed
1207 1208 1209 1210 1211 1212

      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
1213 1214 1215 1216 1217 1218 1219
      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");
1220
      tmp = gfc_call_malloc (&se->pre, type,
1221 1222 1223 1224
			     fold_build2_loc (input_location, MULT_EXPR,
					      TREE_TYPE (len), len,
					      fold_convert (TREE_TYPE (len),
							    TYPE_SIZE (type))));
1225
      gfc_add_modify (&se->pre, var, tmp);
dnovillo's avatar
 
dnovillo committed
1226 1227

      /* Free the temporary afterwards.  */
1228
      tmp = gfc_call_free (convert (pvoid_type_node, var));
dnovillo's avatar
 
dnovillo committed
1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241
      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)
{
1242 1243
  gfc_se lse, rse;
  tree len, type, var, tmp, fndecl;
dnovillo's avatar
 
dnovillo committed
1244

1245
  gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1246
	      && expr->value.op.op2->ts.type == BT_CHARACTER);
1247
  gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
dnovillo's avatar
 
dnovillo committed
1248 1249

  gfc_init_se (&lse, se);
1250
  gfc_conv_expr (&lse, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1251 1252
  gfc_conv_string_parameter (&lse);
  gfc_init_se (&rse, se);
1253
  gfc_conv_expr (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
1254 1255 1256 1257 1258
  gfc_conv_string_parameter (&rse);

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

1259
  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
dnovillo's avatar
 
dnovillo committed
1260 1261 1262
  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
  if (len == NULL_TREE)
    {
1263 1264 1265
      len = fold_build2_loc (input_location, PLUS_EXPR,
			     TREE_TYPE (lse.string_length),
			     lse.string_length, rse.string_length);
dnovillo's avatar
 
dnovillo committed
1266 1267 1268 1269 1270 1271 1272
    }

  type = build_pointer_type (type);

  var = gfc_conv_string_tmp (se, type, len);

  /* Do the actual concatenation.  */
1273 1274 1275 1276 1277 1278 1279
  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 ();

1280 1281
  tmp = build_call_expr_loc (input_location,
			 fndecl, 6, len, var, lse.string_length, lse.expr,
1282
			 rse.string_length, rse.expr);
dnovillo's avatar
 
dnovillo committed
1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295
  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
1296
   operator **).
dnovillo's avatar
 
dnovillo committed
1297
   Operators need no special handling for scalarized expressions as long as
1298
   they call gfc_conv_simple_val to get their operands.
dnovillo's avatar
 
dnovillo committed
1299 1300 1301 1302 1303 1304 1305 1306
   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
1307
  tree tmp, type;
dnovillo's avatar
 
dnovillo committed
1308 1309 1310 1311 1312
  int lop;
  int checkstring;

  checkstring = 0;
  lop = 0;
1313
  switch (expr->value.op.op)
dnovillo's avatar
 
dnovillo committed
1314
    {
tobi's avatar
tobi committed
1315
    case INTRINSIC_PARENTHESES:
1316 1317 1318
      if ((expr->ts.type == BT_REAL
	   || expr->ts.type == BT_COMPLEX)
	  && gfc_option.flag_protect_parens)
1319 1320 1321 1322 1323 1324 1325 1326
	{
	  gfc_conv_unary_op (PAREN_EXPR, se, expr);
	  gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
	  return;
	}

      /* Fallthrough.  */
    case INTRINSIC_UPLUS:
1327
      gfc_conv_expr (se, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378
      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
1379
         as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
dnovillo's avatar
 
dnovillo committed
1380
    case INTRINSIC_EQ:
dfranke's avatar
dfranke committed
1381
    case INTRINSIC_EQ_OS:
dnovillo's avatar
 
dnovillo committed
1382 1383 1384 1385 1386 1387 1388
    case INTRINSIC_EQV:
      code = EQ_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_NE:
dfranke's avatar
dfranke committed
1389
    case INTRINSIC_NE_OS:
dnovillo's avatar
 
dnovillo committed
1390 1391 1392 1393 1394 1395 1396
    case INTRINSIC_NEQV:
      code = NE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GT:
dfranke's avatar
dfranke committed
1397
    case INTRINSIC_GT_OS:
dnovillo's avatar
 
dnovillo committed
1398 1399 1400 1401 1402 1403
      code = GT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GE:
dfranke's avatar
dfranke committed
1404
    case INTRINSIC_GE_OS:
dnovillo's avatar
 
dnovillo committed
1405 1406 1407 1408 1409 1410
      code = GE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LT:
dfranke's avatar
dfranke committed
1411
    case INTRINSIC_LT_OS:
dnovillo's avatar
 
dnovillo committed
1412 1413 1414 1415 1416 1417
      code = LT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LE:
dfranke's avatar
dfranke committed
1418
    case INTRINSIC_LE_OS:
dnovillo's avatar
 
dnovillo committed
1419 1420 1421 1422 1423 1424 1425 1426
      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
1427
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
1428 1429 1430 1431 1432 1433

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

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

1437
  if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
1438 1439 1440 1441
    checkstring = 0;

  /* lhs */
  gfc_init_se (&lse, se);
1442
  gfc_conv_expr (&lse, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1443 1444 1445 1446
  gfc_add_block_to_block (&se->pre, &lse.pre);

  /* rhs */
  gfc_init_se (&rse, se);
1447
  gfc_conv_expr (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
1448 1449 1450 1451 1452 1453 1454
  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
1455
      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1456
					   rse.string_length, rse.expr,
1457 1458
					   expr->value.op.op1->ts.kind,
					   code);
1459
      rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
fengwang's avatar
fengwang committed
1460
      gfc_add_block_to_block (&lse.post, &rse.post);
dnovillo's avatar
 
dnovillo committed
1461 1462 1463 1464 1465 1466 1467
    }

  type = gfc_typenode_for_spec (&expr->ts);

  if (lop)
    {
      /* The result of logical ops is always boolean_type_node.  */
1468 1469
      tmp = fold_build2_loc (input_location, code, boolean_type_node,
			     lse.expr, rse.expr);
dnovillo's avatar
 
dnovillo committed
1470 1471 1472
      se->expr = convert (type, tmp);
    }
  else
1473
    se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
dnovillo's avatar
 
dnovillo committed
1474 1475 1476 1477 1478 1479

  /* 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
1480 1481
/* If a string's length is one, we convert it to a single character.  */

1482 1483
tree
gfc_string_to_single_character (tree len, tree str, int kind)
fengwang's avatar
fengwang committed
1484 1485
{

1486 1487
  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
      || !POINTER_TYPE_P (TREE_TYPE (str)))
1488 1489 1490
    return NULL_TREE;

  if (TREE_INT_CST_LOW (len) == 1)
fengwang's avatar
fengwang committed
1491
    {
1492
      str = fold_convert (gfc_get_pchar_type (kind), str);
1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511
      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);
1512
	  int i, length = TREE_STRING_LENGTH (string_cst);
1513 1514
	  const char *ptr = TREE_STRING_POINTER (string_cst);

1515
	  for (i = 1; i < length; i++)
1516 1517 1518 1519 1520
	    if (ptr[i] != ' ')
	      return NULL_TREE;

	  return ret;
	}
fengwang's avatar
fengwang committed
1521 1522 1523 1524 1525
    }

  return NULL_TREE;
}

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

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;
1551
          gfc_clear_ts (&ts);
1552

1553 1554
	  *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
				    (int)(*expr)->value.character.string[0]);
1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567
	  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)
	    {
1568
	      se->expr = gfc_string_to_single_character
1569
		(build_int_cst (integer_type_node, 1),
1570
		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1571
				      gfc_get_symbol_decl
1572 1573
				      ((*expr)->symtree->n.sym)),
		 (*expr)->ts.kind);
1574 1575 1576 1577
	    }
	  else
	    {
	      gfc_conv_variable (se, *expr);
1578
	      se->expr = gfc_string_to_single_character
1579
		(build_int_cst (integer_type_node, 1),
1580 1581 1582
		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
				      se->expr),
		 (*expr)->ts.kind);
1583 1584 1585 1586 1587
	    }
	}
    }
}

1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621
/* 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;
}
1622

fengwang's avatar
fengwang committed
1623 1624 1625 1626
/* Compare two strings. If they are all single characters, the result is the
   subtraction of them. Otherwise, we build a library call.  */

tree
1627 1628
gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
			  enum tree_code code)
fengwang's avatar
fengwang committed
1629 1630 1631
{
  tree sc1;
  tree sc2;
1632
  tree fndecl;
fengwang's avatar
fengwang committed
1633 1634 1635 1636

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

1637 1638
  sc1 = gfc_string_to_single_character (len1, str1, kind);
  sc2 = gfc_string_to_single_character (len2, str2, kind);
fengwang's avatar
fengwang committed
1639 1640 1641

  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
    {
1642
      /* Deal with single character specially.  */
fxcoudert's avatar
fxcoudert committed
1643 1644
      sc1 = fold_convert (integer_type_node, sc1);
      sc2 = fold_convert (integer_type_node, sc2);
1645 1646
      return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
			      sc1, sc2);
fengwang's avatar
fengwang committed
1647
    }
1648

1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661
  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;
1662 1663
    }

1664 1665 1666 1667 1668 1669 1670 1671 1672 1673
  /* 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
1674
}
1675

1676 1677 1678 1679 1680 1681 1682 1683

/* 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;
1684 1685
  expr_t old_type;

1686 1687
  gfc_init_se (&comp_se, NULL);
  e2 = gfc_copy_expr (e);
1688 1689 1690 1691
  /* 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;
1692 1693
  e2->expr_type = EXPR_VARIABLE;
  gfc_conv_expr (&comp_se, e2);
1694
  e2->expr_type = old_type;
1695
  gfc_free_expr (e2);
1696 1697 1698 1699
  return build_fold_addr_expr_loc (input_location, comp_se.expr);
}


dnovillo's avatar
 
dnovillo committed
1700
static void
1701
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
dnovillo's avatar
 
dnovillo committed
1702 1703 1704
{
  tree tmp;

1705
  if (gfc_is_proc_ptr_comp (expr, NULL))
1706
    tmp = get_proc_ptr_comp (expr);
1707
  else if (sym->attr.dummy)
dnovillo's avatar
 
dnovillo committed
1708 1709
    {
      tmp = gfc_get_symbol_decl (sym);
1710
      if (sym->attr.proc_pointer)
1711 1712
        tmp = build_fold_indirect_ref_loc (input_location,
				       tmp);
pbrook's avatar
pbrook committed
1713
      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
dnovillo's avatar
 
dnovillo committed
1714 1715 1716 1717 1718 1719 1720 1721
	      && 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;
1722

1723
      if (sym->attr.cray_pointee)
1724 1725 1726 1727 1728 1729 1730 1731 1732
	{
	  /* 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
1733 1734 1735
      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
	{
	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1736
	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
rsandifo's avatar
rsandifo committed
1737 1738 1739 1740 1741 1742 1743 1744
	}
    }
  se->expr = tmp;
}


/* Initialize MAPPING.  */

rsandifo's avatar
rsandifo committed
1745
void
rsandifo's avatar
rsandifo committed
1746 1747 1748 1749 1750 1751 1752 1753 1754
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
1755
void
rsandifo's avatar
rsandifo committed
1756 1757 1758 1759 1760 1761 1762 1763 1764 1765
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;
1766
      sym->new_sym->n.sym->formal = NULL;
ghazi's avatar
ghazi committed
1767
      gfc_free_symbol (sym->new_sym->n.sym);
1768
      gfc_free_expr (sym->expr);
1769 1770
      free (sym->new_sym);
      free (sym);
rsandifo's avatar
rsandifo committed
1771 1772 1773 1774 1775
    }
  for (cl = mapping->charlens; cl; cl = nextcl)
    {
      nextcl = cl->next;
      gfc_free_expr (cl->length);
1776
      free (cl);
dnovillo's avatar
 
dnovillo committed
1777 1778 1779 1780
    }
}


rsandifo's avatar
rsandifo committed
1781 1782 1783 1784 1785 1786 1787
/* 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
1788
  gfc_charlen *new_charlen;
rsandifo's avatar
rsandifo committed
1789

ghazi's avatar
ghazi committed
1790 1791 1792
  new_charlen = gfc_get_charlen ();
  new_charlen->next = mapping->charlens;
  new_charlen->length = gfc_copy_expr (cl->length);
rsandifo's avatar
rsandifo committed
1793

ghazi's avatar
ghazi committed
1794 1795
  mapping->charlens = new_charlen;
  return new_charlen;
rsandifo's avatar
rsandifo committed
1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806
}


/* 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
1807
				 gfc_packed packed, tree data)
rsandifo's avatar
rsandifo committed
1808 1809 1810 1811 1812
{
  tree type;
  tree var;

  type = gfc_typenode_for_spec (&sym->ts);
1813 1814 1815
  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
1816

1817
  var = gfc_create_var (type, "ifm");
1818
  gfc_add_modify (block, var, fold_convert (type, data));
rsandifo's avatar
rsandifo committed
1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838

  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++)
    {
1839
      dim = gfc_rank_cst[n];
rsandifo's avatar
rsandifo committed
1840
      GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1841 1842 1843
      if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
	{
	  GFC_TYPE_ARRAY_LBOUND (type, n)
1844
		= gfc_conv_descriptor_lbound_get (desc, dim);
1845
	  GFC_TYPE_ARRAY_UBOUND (type, n)
1846
		= gfc_conv_descriptor_ubound_get (desc, dim);
1847 1848
	}
      else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
rsandifo's avatar
rsandifo committed
1849
	{
1850 1851 1852 1853 1854 1855 1856
	  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
1857 1858 1859
	  tmp = gfc_evaluate_now (tmp, block);
	  GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
	}
1860 1861 1862 1863 1864
      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
1865 1866 1867 1868 1869 1870 1871 1872 1873 1874
    }
  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
1875
void
rsandifo's avatar
rsandifo committed
1876
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1877 1878
			   gfc_symbol * sym, gfc_se * se,
			   gfc_expr *expr)
rsandifo's avatar
rsandifo committed
1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890
{
  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
1891
  new_sym->as = gfc_copy_array_spec (sym->as);
rsandifo's avatar
rsandifo committed
1892 1893
  new_sym->attr.referenced = 1;
  new_sym->attr.dimension = sym->attr.dimension;
1894
  new_sym->attr.contiguous = sym->attr.contiguous;
1895
  new_sym->attr.codimension = sym->attr.codimension;
rsandifo's avatar
rsandifo committed
1896
  new_sym->attr.pointer = sym->attr.pointer;
eedelman's avatar
eedelman committed
1897
  new_sym->attr.allocatable = sym->attr.allocatable;
rsandifo's avatar
rsandifo committed
1898
  new_sym->attr.flavor = sym->attr.flavor;
1899
  new_sym->attr.function = sym->attr.function;
rsandifo's avatar
rsandifo committed
1900

1901 1902 1903 1904
  /* Ensure that the interface is available and that
     descriptors are passed for array actual arguments.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    {
1905
      new_sym->formal = expr->symtree->n.sym->formal;
1906 1907 1908 1909
      new_sym->attr.always_explicit
	    = expr->symtree->n.sym->attr.always_explicit;
    }

rsandifo's avatar
rsandifo committed
1910 1911 1912 1913 1914 1915 1916
  /* 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.  */
1917
  sm = XCNEW (gfc_interface_sym_mapping);
rsandifo's avatar
rsandifo committed
1918 1919
  sm->next = mapping->syms;
  sm->old = sym;
ghazi's avatar
ghazi committed
1920
  sm->new_sym = new_symtree;
1921
  sm->expr = gfc_copy_expr (expr);
rsandifo's avatar
rsandifo committed
1922 1923 1924
  mapping->syms = sm;

  /* Stabilize the argument's value.  */
1925 1926
  if (!sym->attr.function && se)
    se->expr = gfc_evaluate_now (se->expr, &se->pre);
rsandifo's avatar
rsandifo committed
1927 1928 1929 1930

  if (sym->ts.type == BT_CHARACTER)
    {
      /* Create a copy of the dummy argument's length.  */
1931 1932
      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
1933 1934 1935 1936

      /* 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.  */
1937
      if (!new_sym->ts.u.cl->length && se)
rsandifo's avatar
rsandifo committed
1938 1939
	{
	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1940
	  new_sym->ts.u.cl->backend_decl = se->string_length;
rsandifo's avatar
rsandifo committed
1941 1942 1943
	}
    }

1944 1945 1946
  if (!se)
    return;

rsandifo's avatar
rsandifo committed
1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957
  /* 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)
1958 1959
        value = build_fold_indirect_ref_loc (input_location,
					 se->expr);
1960 1961 1962
      else
        value = se->expr;
      value = fold_convert (tmp, value);
rsandifo's avatar
rsandifo committed
1963 1964
    }

eedelman's avatar
eedelman committed
1965 1966 1967
  /* 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)
1968 1969
    value = build_fold_indirect_ref_loc (input_location,
				     se->expr);
1970 1971
  
  /* For character(*), use the actual argument's descriptor.  */  
1972
  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1973 1974
    value = build_fold_indirect_ref_loc (input_location,
				     se->expr);
rsandifo's avatar
rsandifo committed
1975 1976 1977 1978 1979 1980 1981

  /* 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.  */
1982 1983
      desc = build_fold_indirect_ref_loc (input_location,
				      se->expr);
rsandifo's avatar
rsandifo committed
1984 1985 1986

      /* Create the replacement variable.  */
      tmp = gfc_conv_descriptor_data_get (desc);
tobi's avatar
tobi committed
1987 1988
      value = gfc_get_interface_mapping_array (&se->pre, sym,
					       PACKED_NO, tmp);
rsandifo's avatar
rsandifo committed
1989 1990 1991 1992 1993 1994

      /* 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
1995 1996
    value = gfc_get_interface_mapping_array (&se->pre, sym,
					     PACKED_FULL, se->expr);
rsandifo's avatar
rsandifo committed
1997 1998 1999 2000 2001 2002 2003 2004 2005 2006

  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
2007
void
rsandifo's avatar
rsandifo committed
2008 2009 2010 2011 2012 2013 2014 2015
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
2016
    if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2017
	&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
rsandifo's avatar
rsandifo committed
2018
      {
2019
	expr = sym->new_sym->n.sym->ts.u.cl->length;
rsandifo's avatar
rsandifo committed
2020 2021 2022
	gfc_apply_interface_mapping_to_expr (mapping, expr);
	gfc_init_se (&se, NULL);
	gfc_conv_expr (&se, expr);
2023
	se.expr = fold_convert (gfc_charlen_type_node, se.expr);
rsandifo's avatar
rsandifo committed
2024 2025 2026 2027
	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);

2028
	sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
rsandifo's avatar
rsandifo committed
2029 2030 2031 2032 2033 2034 2035 2036 2037
      }
}


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

static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2038
				     gfc_constructor_base base)
rsandifo's avatar
rsandifo committed
2039
{
2040 2041
  gfc_constructor *c;
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
rsandifo's avatar
rsandifo committed
2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086
    {
      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;
      }
}


2087
/* Convert intrinsic function calls into result expressions.  */
domob's avatar
domob committed
2088

2089
static bool
domob's avatar
domob committed
2090
gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103
{
  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
2104
  sym = arg1->symtree->n.sym;
2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115

  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
2116 2117 2118
	  && (arg1->ts.u.cl->length == NULL
	      || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
		  && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2119 2120
	return false;

2121
      new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2122 2123 2124
      break;

    case GFC_ISYM_SIZE:
2125
      if (!sym->as || sym->as->rank == 0)
2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141
	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
2142 2143 2144 2145 2146 2147 2148

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

2149 2150 2151
	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
					gfc_get_int_expr (gfc_default_integer_kind,
							  NULL, 1));
2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164
	  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.  */

2165
      if (!sym->as || sym->as->rank == 0)
2166 2167 2168 2169 2170 2171 2172 2173 2174 2175
	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
2176 2177 2178 2179
	{
	  if (sym->as->lower[d])
	    new_expr = gfc_copy_expr (sym->as->lower[d]);
	}
2180
      else
domob's avatar
domob committed
2181 2182 2183 2184
	{
	  if (sym->as->upper[d])
	    new_expr = gfc_copy_expr (sym->as->upper[d]);
	}
2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235
      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)
    {
2236 2237
      expr->value.function.esym->ts.u.cl->length
	= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2238 2239

      gfc_apply_interface_mapping_to_expr (mapping,
2240
			expr->value.function.esym->ts.u.cl->length);
2241 2242 2243 2244
    }
}


rsandifo's avatar
rsandifo committed
2245 2246 2247 2248 2249
/* 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.  */

2250
static void
rsandifo's avatar
rsandifo committed
2251 2252 2253 2254 2255 2256 2257
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
				     gfc_expr * expr)
{
  gfc_interface_sym_mapping *sym;
  gfc_actual_arglist *actual;

  if (!expr)
2258
    return;
rsandifo's avatar
rsandifo committed
2259 2260

  /* Copying an expression does not copy its length, so do that here.  */
2261
  if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
rsandifo's avatar
rsandifo committed
2262
    {
2263 2264
      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
2265 2266 2267 2268 2269 2270
    }

  /* 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.  */
2271
  /* TODO Find out why the condition on expr->symtree had to be moved into
rwild's avatar
rwild committed
2272
     the loop rather than being outside it, as originally.  */
2273 2274 2275
  for (sym = mapping->syms; sym; sym = sym->next)
    if (expr->symtree && sym->old == expr->symtree->n.sym)
      {
ghazi's avatar
ghazi committed
2276 2277
	if (sym->new_sym->n.sym->backend_decl)
	  expr->symtree = sym->new_sym;
2278 2279
	else if (sym->expr)
	  gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2280 2281 2282 2283
	/* Replace base type for polymorphic arguments.  */
	if (expr->ref && expr->ref->type == REF_COMPONENT
	    && sym->expr && sym->expr->ts.type == BT_CLASS)
	  expr->ref->u.c.sym = sym->expr->ts.u.derived;
2284
      }
rsandifo's avatar
rsandifo committed
2285

2286
      /* ...and to subexpressions in expr->value.  */
rsandifo's avatar
rsandifo committed
2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300
  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:
2301 2302 2303
      for (actual = expr->value.function.actual; actual; actual = actual->next)
	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);

2304
      if (expr->value.function.esym == NULL
2305
	    && expr->value.function.isym != NULL
2306 2307 2308
	    && expr->value.function.actual->expr->symtree
	    && gfc_map_intrinsic_function (expr, mapping))
	break;
2309

rsandifo's avatar
rsandifo committed
2310 2311
      for (sym = mapping->syms; sym; sym = sym->next)
	if (sym->old == expr->value.function.esym)
2312
	  {
ghazi's avatar
ghazi committed
2313
	    expr->value.function.esym = sym->new_sym->n.sym;
2314
	    gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
ghazi's avatar
ghazi committed
2315
	    expr->value.function.esym->result = sym->new_sym->n.sym;
2316
	  }
rsandifo's avatar
rsandifo committed
2317 2318 2319 2320 2321 2322
      break;

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

    case EXPR_COMPCALL:
2325
    case EXPR_PPC:
domob's avatar
domob committed
2326 2327
      gcc_unreachable ();
      break;
rsandifo's avatar
rsandifo committed
2328
    }
2329 2330

  return;
rsandifo's avatar
rsandifo committed
2331 2332 2333 2334 2335 2336
}


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

rsandifo's avatar
rsandifo committed
2337
void
rsandifo's avatar
rsandifo committed
2338 2339 2340 2341 2342 2343 2344 2345 2346 2347
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);
}

2348

2349 2350
/* Returns a reference to a temporary array into which a component of
   an actual argument derived type array is copied and then returned
2351
   after the function call.  */
2352
void
2353 2354
gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
			   sym_intent intent, bool formal_ptr)
2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366
{
  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;
2367
  tree size;
2368 2369
  stmtblock_t body;
  int n;
jakub's avatar
jakub committed
2370
  int dimen;
2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389

  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.  */
2390 2391
  if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
    gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2392

2393 2394 2395 2396 2397
  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);

2398 2399 2400 2401
  loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
					      ? expr->ts.u.cl->backend_decl
					      : NULL),
				  loop.dimen);
2402

2403
  parmse->string_length = loop.temp_ss->string_length;
2404 2405 2406 2407 2408

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

  /* Setup the scalarizing loops.  */
2409
  gfc_conv_loop_setup (&loop, &expr->where);
2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431

  /* 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);

2432 2433
  if (intent != INTENT_OUT)
    {
2434
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2435 2436 2437 2438
      gfc_add_expr_to_block (&body, tmp);
      gcc_assert (rse.ss == gfc_ss_terminator);
      gfc_trans_scalarizing_loops (&loop, &body);
    }
2439 2440
  else
    {
2441 2442 2443 2444 2445 2446 2447 2448
      /* 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);
2449
    }
2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472

  /* 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.  */
2473
  gfc_conv_loop_setup (&loop2, &expr->where);
2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489

  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
2490
     optimized further.  */
2491
  info = &rse.ss->data.info;
jakub's avatar
jakub committed
2492
  dimen = info->dimen;
2493 2494

  tmp_index = gfc_index_zero_node;
jakub's avatar
jakub committed
2495
  for (n = dimen - 1; n > 0; n--)
2496 2497 2498
    {
      tree tmp_str;
      tmp = rse.loop->loopvar[n];
2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512
      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);
2513 2514
    }

2515 2516 2517
  tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
			       gfc_array_index_type,
			       tmp_index, rse.loop->from[0]);
2518
  gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2519

2520 2521 2522
  tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
			       gfc_array_index_type,
			       rse.loop->loopvar[0], offset);
2523 2524

  /* Now use the offset for the reference.  */
2525 2526
  tmp = build_fold_indirect_ref_loc (input_location,
				 info->data);
2527
  rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2528 2529

  if (expr->ts.type == BT_CHARACTER)
2530
    rse.string_length = expr->ts.u.cl->backend_decl;
2531 2532 2533 2534 2535

  gfc_conv_expr (&lse, expr);

  gcc_assert (lse.ss == gfc_ss_terminator);

2536
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2537 2538 2539 2540 2541 2542
  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
2543
     and following it by the post-block of the first loop.  In this way,
2544
     if the temporary needs freeing, it is done after use!  */
2545 2546 2547 2548 2549
  if (intent != INTENT_IN)
    {
      gfc_add_block_to_block (&parmse->post, &loop2.pre);
      gfc_add_block_to_block (&parmse->post, &loop2.post);
    }
2550 2551 2552 2553 2554 2555 2556 2557

  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)
2558
    parmse->string_length = expr->ts.u.cl->backend_decl;
2559

2560 2561 2562 2563 2564 2565
  /* 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
2566
      for (n = 0; n < dimen; n++)
2567 2568 2569
	{
	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
						gfc_rank_cst[n]);
2570 2571 2572
	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type, tmp,
				 gfc_index_one_node);
2573 2574 2575 2576 2577 2578 2579 2580 2581
	  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);
2582 2583 2584
	  offset = fold_build2_loc (input_location, MINUS_EXPR,
				    gfc_array_index_type,
				    offset, size);
2585
	  offset = gfc_evaluate_now (offset, &parmse->pre);
2586 2587 2588 2589 2590 2591 2592 2593
	  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);
2594 2595 2596 2597 2598 2599
	}

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

2600 2601 2602 2603 2604
  /* 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
2605
    parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2606 2607 2608 2609

  return;
}

rsandifo's avatar
rsandifo committed
2610

2611 2612 2613 2614 2615 2616 2617 2618 2619 2620
/* 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)
2621
    gfc_conv_expr (se, expr);
2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633
  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
2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653
/* 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.  */
2654
  cmp = gfc_find_component (declared, "_vptr", true, true);
2655 2656 2657
  ctree = fold_build3_loc (input_location, COMPONENT_REF,
			   TREE_TYPE (cmp->backend_decl),
			   var, cmp->backend_decl, NULL_TREE);
janus's avatar
janus committed
2658 2659

  /* Remember the vtab corresponds to the derived type
2660 2661
     not to the class declared type.  */
  vtab = gfc_find_derived_vtab (e->ts.u.derived);
janus's avatar
janus committed
2662 2663 2664 2665 2666 2667
  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.  */
2668
  cmp = gfc_find_component (declared, "_data", true, true);
2669 2670 2671
  ctree = fold_build3_loc (input_location, COMPONENT_REF,
			   TREE_TYPE (cmp->backend_decl),
			   var, cmp->backend_decl, NULL_TREE);
janus's avatar
janus committed
2672 2673 2674
  ss = gfc_walk_expr (e);
  if (ss == gfc_ss_terminator)
    {
2675
      parmse->ss = NULL;
janus's avatar
janus committed
2676 2677 2678 2679 2680 2681
      gfc_conv_expr_reference (parmse, e);
      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
      gfc_add_modify (&parmse->pre, ctree, tmp);
    }
  else
    {
2682
      parmse->ss = ss;
janus's avatar
janus committed
2683 2684 2685 2686 2687 2688 2689 2690 2691
      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);
}


2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776
/* 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);
      
2777 2778 2779 2780 2781
      se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
				  TREE_TYPE (fptrse.expr),
				  fptrse.expr,
				  fold_convert (TREE_TYPE (fptrse.expr),
						cptrse.expr));
2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801

      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.  */
2802 2803 2804 2805
	se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
				    arg1se.expr,
				    fold_convert (TREE_TYPE (arg1se.expr),
						  null_pointer_node));
2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817
      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.  */
2818 2819
	  eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
				     arg1se.expr, arg2se.expr);
2820
	  /* Generate test to ensure that the first arg is not null.  */
2821 2822 2823
	  not_null_expr = fold_build2_loc (input_location, NE_EXPR,
					   boolean_type_node,
					   arg1se.expr, null_pointer_node);
2824 2825 2826

	  /* Finally, the generated test must check that both arg1 is not
	     NULL and that it is equal to the second arg.  */
2827 2828 2829
	  se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
				      boolean_type_node,
				      not_null_expr, eq_expr);
2830 2831 2832 2833 2834 2835 2836 2837 2838
	}

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

2839

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

2845
int
2846
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2847
			 gfc_actual_arglist * args, gfc_expr * expr,
froydnj's avatar
gcc/  
froydnj committed
2848
			 VEC(tree,gc) *append_args)
dnovillo's avatar
 
dnovillo committed
2849
{
rsandifo's avatar
rsandifo committed
2850
  gfc_interface_mapping mapping;
froydnj's avatar
gcc/  
froydnj committed
2851 2852
  VEC(tree,gc) *arglist;
  VEC(tree,gc) *retargs;
dnovillo's avatar
 
dnovillo committed
2853 2854 2855 2856 2857 2858
  tree tmp;
  tree fntype;
  gfc_se parmse;
  gfc_ss *argss;
  gfc_ss_info *info;
  int byref;
2859
  int parm_kind;
dnovillo's avatar
 
dnovillo committed
2860 2861 2862
  tree type;
  tree var;
  tree len;
froydnj's avatar
gcc/  
froydnj committed
2863
  VEC(tree,gc) *stringargs;
2864
  tree result = NULL;
dnovillo's avatar
 
dnovillo committed
2865
  gfc_formal_arglist *formal;
2866
  gfc_actual_arglist *arg;
2867
  int has_alternate_specifier = 0;
rsandifo's avatar
rsandifo committed
2868
  bool need_interface_mapping;
eedelman's avatar
eedelman committed
2869
  bool callee_alloc;
rsandifo's avatar
rsandifo committed
2870 2871
  gfc_typespec ts;
  gfc_charlen cl;
2872 2873
  gfc_expr *e;
  gfc_symbol *fsym;
2874
  stmtblock_t post;
2875
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2876
  gfc_component *comp = NULL;
froydnj's avatar
gcc/  
froydnj committed
2877
  int arglen;
dnovillo's avatar
 
dnovillo committed
2878

froydnj's avatar
gcc/  
froydnj committed
2879 2880 2881
  arglist = NULL;
  retargs = NULL;
  stringargs = NULL;
dnovillo's avatar
 
dnovillo committed
2882 2883
  var = NULL_TREE;
  len = NULL_TREE;
2884
  gfc_clear_ts (&ts);
dnovillo's avatar
 
dnovillo committed
2885

2886
  if (sym->from_intmod == INTMOD_ISO_C_BINDING
2887
      && conv_isocbinding_procedure (se, sym, args))
2888
    return 0;
2889 2890 2891

  gfc_is_proc_ptr_comp (expr, &comp);

dnovillo's avatar
 
dnovillo committed
2892 2893 2894 2895
  if (se->ss != NULL)
    {
      if (!sym->attr.elemental)
	{
pbrook's avatar
pbrook committed
2896
	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2897 2898
	  if (se->ss->useflags)
	    {
2899 2900 2901
	      gcc_assert ((!comp && gfc_return_by_reference (sym)
			   && sym->result->attr.dimension)
			  || (comp && comp->attr.dimension));
2902
	      gcc_assert (se->loop != NULL);
dnovillo's avatar
 
dnovillo committed
2903

2904 2905 2906 2907
	      /* Access the previously obtained result.  */
	      gfc_conv_tmp_array_ref (se);
	      return 0;
	    }
dnovillo's avatar
 
dnovillo committed
2908 2909 2910 2911 2912 2913
	}
      info = &se->ss->data.info;
    }
  else
    info = NULL;

2914
  gfc_init_block (&post);
rsandifo's avatar
rsandifo committed
2915
  gfc_init_interface_mapping (&mapping);
2916 2917 2918 2919 2920 2921 2922 2923 2924
  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);
    }
2925
  else
2926 2927 2928 2929 2930 2931 2932 2933 2934
    {
      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
2935
  /* Evaluate the arguments.  */
2936 2937
  for (arg = args; arg != NULL;
       arg = arg->next, formal = formal ? formal->next : NULL)
dnovillo's avatar
 
dnovillo committed
2938
    {
2939 2940
      e = arg->expr;
      fsym = formal ? formal->sym : NULL;
2941
      parm_kind = MISSING;
2942

2943
      if (e == NULL)
dnovillo's avatar
 
dnovillo committed
2944 2945 2946 2947 2948 2949 2950 2951 2952
	{
	  if (se->ignore_optional)
	    {
	      /* Some intrinsics have already been resolved to the correct
	         parameters.  */
	      continue;
	    }
	  else if (arg->label)
	    {
2953 2954
	      has_alternate_specifier = 1;
	      continue;
dnovillo's avatar
 
dnovillo committed
2955 2956 2957 2958 2959 2960
	    }
	  else
	    {
	      /* Pass a NULL pointer for an absent arg.  */
	      gfc_init_se (&parmse, NULL);
	      parmse.expr = null_pointer_node;
2961
	      if (arg->missing_arg_type == BT_CHARACTER)
2962
		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
dnovillo's avatar
 
dnovillo committed
2963 2964
	    }
	}
2965 2966 2967 2968 2969 2970 2971 2972 2973
      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
2974 2975 2976 2977 2978 2979
      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
2980
	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
burnus's avatar
burnus committed
2981
	}
dnovillo's avatar
 
dnovillo committed
2982 2983 2984
      else if (se->ss && se->ss->useflags)
	{
	  /* An elemental function inside a scalarized loop.  */
2985 2986
	  gfc_init_se (&parmse, se);
	  gfc_conv_expr_reference (&parmse, e);
2987
	  parm_kind = ELEMENTAL;
dnovillo's avatar
 
dnovillo committed
2988 2989 2990 2991 2992
	}
      else
	{
	  /* A scalar or transformational function.  */
	  gfc_init_se (&parmse, NULL);
2993
	  argss = gfc_walk_expr (e);
dnovillo's avatar
 
dnovillo committed
2994 2995

	  if (argss == gfc_ss_terminator)
2996
	    {
2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008
	      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)
3009
		{
3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021
		  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);
3022
		}
3023 3024 3025 3026
	      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);
3027
	      else if ((e->expr_type == EXPR_FUNCTION)
3028 3029 3030 3031 3032
			&& ((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)
3033 3034
		{
		  gfc_conv_expr (&parmse, e);
3035
		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3036
		}
3037 3038
	      else if (e->expr_type == EXPR_FUNCTION
		       && e->symtree->n.sym->result
3039
		       && e->symtree->n.sym->result != e->symtree->n.sym
3040 3041 3042 3043 3044 3045 3046
		       && 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);
		}
3047 3048 3049
	      else
		{
		  gfc_conv_expr_reference (&parmse, e);
3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061

		  /* 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);
3062 3063 3064
		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
					     void_type_node, parmse.expr,
					     null_pointer_node);
3065 3066 3067 3068 3069 3070
		      gfc_add_expr_to_block (&block, tmp);

		      if (fsym->attr.optional
			  && e->expr_type == EXPR_VARIABLE
			  && e->symtree->n.sym->attr.optional)
			{
3071 3072
			  tmp = fold_build3_loc (input_location, COND_EXPR,
				     void_type_node,
3073 3074 3075 3076 3077 3078 3079 3080 3081 3082
				     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);
		    }

3083 3084 3085
		  if (fsym && e->expr_type != EXPR_NULL
		      && ((fsym->attr.pointer
			   && fsym->attr.flavor != FL_PROCEDURE)
3086 3087
			  || (fsym->attr.proc_pointer
			      && !(e->expr_type == EXPR_VARIABLE
3088 3089 3090
				   && e->symtree->n.sym->attr.dummy))
			  || (fsym->attr.proc_pointer
			      && e->expr_type == EXPR_VARIABLE
3091 3092
			      && gfc_is_proc_ptr_comp (e, NULL))
			  || fsym->attr.allocatable))
3093 3094 3095 3096 3097
		    {
		      /* Scalar pointer dummy args require an extra level of
			 indirection. The null pointer already contains
			 this level of indirection.  */
		      parm_kind = SCALAR_POINTER;
3098
		      parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3099 3100 3101
		    }
		}
	    }
dnovillo's avatar
 
dnovillo committed
3102 3103
	  else
	    {
eedelman's avatar
eedelman committed
3104 3105 3106 3107 3108 3109
              /* 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.  */
3110
	      bool f;
3111 3112
	      f = (fsym != NULL)
		  && !(fsym->attr.pointer || fsym->attr.allocatable)
3113
		  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3114 3115 3116 3117
	      if (comp)
		f = f || !comp->attr.always_explicit;
	      else
		f = f || !sym->attr.always_explicit;
3118

3119 3120 3121 3122 3123 3124
	      /* 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)
		{
3125
		  gfc_expr *iarg;
3126 3127 3128 3129 3130 3131 3132 3133 3134 3135
		  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;
3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154

		  iarg = e->value.function.actual->expr;

		  /* Temporary needed if aliasing due to host association.  */
		  if (sym->attr.contained
			&& !sym->attr.pure
			&& !sym->attr.implicit_pure
			&& !sym->attr.use_assoc
			&& iarg->expr_type == EXPR_VARIABLE
			&& sym->ns == iarg->symtree->n.sym->ns)
		    parmse.force_tmp = 1;

		  /* Ditto within module.  */
		  if (sym->attr.use_assoc
			&& !sym->attr.pure
			&& !sym->attr.implicit_pure
			&& iarg->expr_type == EXPR_VARIABLE
			&& sym->module == iarg->symtree->n.sym->module)
		    parmse.force_tmp = 1;
3155 3156
		}

3157
	      if (e->expr_type == EXPR_VARIABLE
3158
		    && is_subref_array (e))
3159 3160 3161 3162
		/* 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.  */
3163
		gfc_conv_subref_array_arg (&parmse, e, f,
3164 3165
				fsym ? fsym->attr.intent : INTENT_INOUT,
				fsym && fsym->attr.pointer);
3166
	      else
3167
	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
jakub's avatar
jakub committed
3168
					  sym->name, NULL);
eedelman's avatar
eedelman committed
3169

3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180
	      /* 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)
3181 3182
		    tmp = fold_build3_loc (input_location, COND_EXPR,
				     void_type_node,
3183 3184 3185 3186
				     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
3187 3188 3189
	    } 
	}

fxcoudert's avatar
fxcoudert committed
3190 3191 3192 3193 3194 3195
      /* 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))
3196
	{
fxcoudert's avatar
fxcoudert committed
3197
	  /* If an optional argument is itself an optional dummy argument,
3198 3199 3200 3201
	     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.
3202 3203 3204 3205 3206 3207
	     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
3208
	  if (e->expr_type == EXPR_VARIABLE
3209 3210 3211
	      && e->symtree->n.sym->attr.optional
	      && ((e->rank > 0 && sym->attr.elemental)
		  || e->representation.length || e->ts.type == BT_CHARACTER
3212
		  || (e->rank > 0
3213 3214 3215 3216
		      && (fsym == NULL 
			  || (fsym-> as
			      && (fsym->as->type == AS_ASSUMED_SHAPE
			      	  || fsym->as->type == AS_DEFERRED))))))
3217 3218
	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
				    e->representation.length);
fxcoudert's avatar
fxcoudert committed
3219 3220 3221 3222 3223 3224 3225 3226 3227 3228
	}

      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
3229 3230
	      && e->symtree->n.sym->ts.u.cl->length != NULL
	      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3231
	    {
3232 3233
	      gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
	      parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3234 3235
	    }
	}
rsandifo's avatar
rsandifo committed
3236

3237
      if (fsym && need_interface_mapping && e)
3238
	gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
fxcoudert's avatar
fxcoudert committed
3239

dnovillo's avatar
 
dnovillo committed
3240
      gfc_add_block_to_block (&se->pre, &parmse.pre);
3241
      gfc_add_block_to_block (&post, &parmse.post);
dnovillo's avatar
 
dnovillo committed
3242

3243
      /* Allocated allocatable components of derived types must be
3244 3245
	 deallocated for non-variable scalars.  Non-variable arrays are
	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
3246
      if (e && e->ts.type == BT_DERIVED
3247
	    && e->ts.u.derived->attr.alloc_comp
3248
	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
3249
	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
3250 3251
        {
	  int parm_rank;
3252 3253
	  tmp = build_fold_indirect_ref_loc (input_location,
					 parmse.expr);
3254 3255 3256 3257 3258 3259 3260 3261 3262
	  parm_rank = e->rank;
	  switch (parm_kind)
	    {
	    case (ELEMENTAL):
	    case (SCALAR):
	      parm_rank = 0;
	      break;

	    case (SCALAR_POINTER):
3263 3264
              tmp = build_fold_indirect_ref_loc (input_location,
					     tmp);
3265 3266 3267
	      break;
	    }

3268 3269 3270 3271 3272 3273
	  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);
3274
	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3275 3276 3277
	      gfc_add_expr_to_block (&se->post, local_tmp);
	    }

3278
	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3279

3280
	  gfc_add_expr_to_block (&se->post, tmp);
3281 3282
        }

3283 3284 3285
      /* Add argument checking of passing an unallocated/NULL actual to
         a nonallocatable/nonpointer dummy.  */

3286
      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3287
        {
3288
	  symbol_attribute attr;
3289 3290 3291
	  char *msg;
	  tree cond;

3292 3293
	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
	    attr = gfc_expr_attr (e);
3294 3295 3296
	  else
	    goto end_pointer_check;

3297 3298 3299 3300 3301 3302
	  /*  In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
	      allocatable to an optional dummy, cf. 12.5.2.12.  */
	  if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
	      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
	    goto end_pointer_check;

3303
          if (attr.optional)
3304 3305 3306 3307 3308 3309
	    {
              /* 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
3310
	      tree present, null_ptr, type;
3311

3312
	      if (attr.allocatable
3313 3314 3315
		  && (fsym == NULL || !fsym->attr.allocatable))
		asprintf (&msg, "Allocatable actual argument '%s' is not "
			  "allocated or not present", e->symtree->n.sym->name);
3316
	      else if (attr.pointer
3317 3318 3319 3320
		       && (fsym == NULL || !fsym->attr.pointer))
		asprintf (&msg, "Pointer actual argument '%s' is not "
			  "associated or not present",
			  e->symtree->n.sym->name);
3321
	      else if (attr.proc_pointer
3322 3323 3324 3325 3326 3327 3328 3329 3330
		       && (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);
3331 3332 3333 3334
	      present = fold_build2_loc (input_location, EQ_EXPR,
					 boolean_type_node, present,
					 fold_convert (type,
						       null_pointer_node));
3335
	      type = TREE_TYPE (parmse.expr);
3336 3337 3338 3339 3340 3341
	      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);
3342 3343 3344
	    }
          else
	    {
3345
	      if (attr.allocatable
3346 3347 3348
		  && (fsym == NULL || !fsym->attr.allocatable))
		asprintf (&msg, "Allocatable actual argument '%s' is not "
		      "allocated", e->symtree->n.sym->name);
3349
	      else if (attr.pointer
3350 3351 3352
		       && (fsym == NULL || !fsym->attr.pointer))
		asprintf (&msg, "Pointer actual argument '%s' is not "
		      "associated", e->symtree->n.sym->name);
3353
	      else if (attr.proc_pointer
3354 3355 3356 3357 3358 3359 3360
		       && (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;


3361 3362 3363 3364
	      cond = fold_build2_loc (input_location, EQ_EXPR,
				      boolean_type_node, parmse.expr,
				      fold_convert (TREE_TYPE (parmse.expr),
						    null_pointer_node));
3365
	    }
3366 3367 3368
 
	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
				   msg);
3369
	  free (msg);
3370 3371 3372
        }
      end_pointer_check:

3373 3374 3375 3376 3377 3378 3379 3380 3381
      /* Deferred length dummies pass the character length by reference
	 so that the value can be returned.  */
      if (parmse.string_length && fsym && fsym->ts.deferred)
	{
	  tmp = parmse.string_length;
	  if (TREE_CODE (tmp) != VAR_DECL)
	    tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
	  parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
	}
3382

3383
      /* Character strings are passed as two parameters, a length and a
3384 3385
         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
3386
	VEC_safe_push (tree, gc, stringargs, parmse.string_length);
dnovillo's avatar
 
dnovillo committed
3387

3388 3389
      /* For descriptorless coarrays and assumed-shape coarray dummies, we
	 pass the token and the offset as additional arguments.  */
3390 3391
      if (fsym && fsym->attr.codimension
	  && gfc_option.coarray == GFC_FCOARRAY_LIB
3392
	  && !fsym->attr.allocatable
3393
	  && e == NULL)
3394 3395 3396 3397 3398
	{
	  /* Token and offset. */
	  VEC_safe_push (tree, gc, stringargs, null_pointer_node);
	  VEC_safe_push (tree, gc, stringargs,
			 build_int_cst (gfc_array_index_type, 0));
3399
	  gcc_assert (fsym->attr.optional);
3400 3401
	}
      else if (fsym && fsym->attr.codimension
3402
	       && !fsym->attr.allocatable
3403 3404 3405
	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
	{
	  tree caf_decl, caf_type;
3406
	  tree offset, tmp2;
3407

3408
	  caf_decl = get_tree_for_caf_expr (e);
3409 3410
	  caf_type = TREE_TYPE (caf_decl);

3411 3412
	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3413
	    tmp = gfc_conv_descriptor_token (caf_decl);
3414 3415 3416
	  else if (DECL_LANG_SPECIFIC (caf_decl)
		   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
	    tmp = GFC_DECL_TOKEN (caf_decl);
3417 3418 3419 3420 3421 3422
	  else
	    {
	      gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
			  && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
	      tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
	    }
3423
	  
3424
	  VEC_safe_push (tree, gc, stringargs, tmp);
3425

3426 3427
	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3428
	    offset = build_int_cst (gfc_array_index_type, 0);
3429 3430 3431
	  else if (DECL_LANG_SPECIFIC (caf_decl)
		   && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
	    offset = GFC_DECL_CAF_OFFSET (caf_decl);
3432
	  else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3433 3434 3435 3436
	    offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
	  else
	    offset = build_int_cst (gfc_array_index_type, 0);

3437 3438 3439 3440 3441 3442 3443 3444
	  if (GFC_DESCRIPTOR_TYPE_P (caf_type))
	    tmp = gfc_conv_descriptor_data_get (caf_decl);
	  else
	    {
	      gcc_assert (POINTER_TYPE_P (caf_type));
	      tmp = caf_decl;
	    }

3445 3446 3447 3448 3449 3450 3451 3452 3453
          if (fsym->as->type == AS_ASSUMED_SHAPE)
	    {
	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
						   (TREE_TYPE (parmse.expr))));
	      tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
	      tmp2 = gfc_conv_descriptor_data_get (tmp2);
	    }
	  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3454 3455 3456 3457 3458 3459
	    tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
	  else
	    {
	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
	      tmp2 = parmse.expr;
	    }
3460 3461 3462

	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                 gfc_array_index_type,
3463 3464
                                 fold_convert (gfc_array_index_type, tmp2),
                                 fold_convert (gfc_array_index_type, tmp));
3465 3466 3467 3468 3469 3470
	  offset = fold_build2_loc (input_location, PLUS_EXPR,
				    gfc_array_index_type, offset, tmp);

	  VEC_safe_push (tree, gc, stringargs, offset);
	}

froydnj's avatar
gcc/  
froydnj committed
3471
      VEC_safe_push (tree, gc, arglist, parmse.expr);
dnovillo's avatar
 
dnovillo committed
3472
    }
rsandifo's avatar
rsandifo committed
3473 3474
  gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);

3475 3476 3477 3478 3479
  if (comp)
    ts = comp->ts;
  else
   ts = sym->ts;

3480 3481 3482
  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
3483
    {
3484
      if (ts.u.cl->length == NULL)
3485 3486 3487
	{
	  /* 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
3488 3489 3490 3491
	     (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.*/
3492 3493 3494
	  if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
	    cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
	  else if (!sym->attr.dummy)
froydnj's avatar
gcc/  
froydnj committed
3495
	    cl.backend_decl = VEC_index (tree, stringargs, 0);
3496 3497 3498 3499 3500
	  else
	    {
	      formal = sym->ns->proc_name->formal;
	      for (; formal; formal = formal->next)
		if (strcmp (formal->sym->name, sym->name) == 0)
3501
		  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3502 3503
	    }
        }
3504
      else
3505
        {
fxcoudert's avatar
fxcoudert committed
3506 3507
	  tree tmp;

3508 3509 3510
	  /* Calculate the length of the returned string.  */
	  gfc_init_se (&parmse, NULL);
	  if (need_interface_mapping)
3511
	    gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3512
	  else
3513
	    gfc_conv_expr (&parmse, ts.u.cl->length);
3514 3515
	  gfc_add_block_to_block (&se->pre, &parmse.pre);
	  gfc_add_block_to_block (&se->post, &parmse.post);
fxcoudert's avatar
fxcoudert committed
3516 3517
	  
	  tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3518 3519 3520
	  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
3521
	  cl.backend_decl = tmp;
3522
	}
rsandifo's avatar
rsandifo committed
3523 3524 3525 3526

      /* Set up a charlen structure for it.  */
      cl.next = NULL;
      cl.length = NULL;
3527
      ts.u.cl = &cl;
rsandifo's avatar
rsandifo committed
3528 3529 3530 3531

      len = cl.backend_decl;
    }

3532
  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3533
	  || (!comp && gfc_return_by_reference (sym));
rsandifo's avatar
rsandifo committed
3534 3535 3536
  if (byref)
    {
      if (se->direct_byref)
3537
	{
rwild's avatar
rwild committed
3538
	  /* Sometimes, too much indirection can be applied; e.g. for
3539 3540 3541 3542 3543
	     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)))))
3544 3545
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
3546

3547 3548
	  /* If the lhs of an assignment x = f(..) is allocatable and
	     f2003 is allowed, we must do the automatic reallocation.
3549
	     TODO - deal with intrinsics, without using a temporary.  */
3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570
	  if (gfc_option.flag_realloc_lhs
		&& se->ss && se->ss->loop_chain
		&& se->ss->loop_chain->is_alloc_lhs
		&& !expr->value.function.isym
		&& sym->result->as != NULL)
	    {
	      /* Evaluate the bounds of the result, if known.  */
	      gfc_set_loop_bounds_from_array_spec (&mapping, se,
						   sym->result->as);

	      /* Perform the automatic reallocation.  */
	      tmp = gfc_alloc_allocatable_for_assignment (se->loop,
							  expr, NULL);
	      gfc_add_expr_to_block (&se->pre, tmp);

	      /* Pass the temporary as the first argument.  */
	      result = info->descriptor;
	    }
	  else
	    result = build_fold_indirect_ref_loc (input_location,
						  se->expr);
froydnj's avatar
gcc/  
froydnj committed
3571
	  VEC_safe_push (tree, gc, retargs, se->expr);
3572
	}
3573 3574 3575 3576 3577 3578
      else if (comp && comp->attr.dimension)
	{
	  gcc_assert (se->loop && info);

	  /* Set the type of the array.  */
	  tmp = gfc_typenode_for_spec (&comp->ts);
3579
	  gcc_assert (info->dimen == se->loop->dimen);
3580 3581 3582 3583

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

3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594
	  /* If the lhs of an assignment x = f(..) is allocatable and
	     f2003 is allowed, we must not generate the function call
	     here but should just send back the results of the mapping.
	     This is signalled by the function ss being flagged.  */
	  if (gfc_option.flag_realloc_lhs
		&& se->ss && se->ss->is_alloc_lhs)
	    {
	      gfc_free_interface_mapping (&mapping);
	      return has_alternate_specifier;
	    }

3595 3596 3597 3598 3599 3600 3601 3602 3603
	  /* 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.  */
3604 3605
	  result = info->descriptor;
	  tmp = gfc_build_addr_expr (NULL_TREE, result);
froydnj's avatar
gcc/  
froydnj committed
3606
	  VEC_safe_push (tree, gc, retargs, tmp);
3607
	}
3608
      else if (!comp && sym->result->attr.dimension)
rsandifo's avatar
rsandifo committed
3609 3610 3611 3612 3613
	{
	  gcc_assert (se->loop && info);

	  /* Set the type of the array.  */
	  tmp = gfc_typenode_for_spec (&ts);
3614
	  gcc_assert (info->dimen == se->loop->dimen);
rsandifo's avatar
rsandifo committed
3615

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

3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629
	  /* If the lhs of an assignment x = f(..) is allocatable and
	     f2003 is allowed, we must not generate the function call
	     here but should just send back the results of the mapping.
	     This is signalled by the function ss being flagged.  */
	  if (gfc_option.flag_realloc_lhs
		&& se->ss && se->ss->is_alloc_lhs)
	    {
	      gfc_free_interface_mapping (&mapping);
	      return has_alternate_specifier;
	    }

eedelman's avatar
eedelman committed
3630 3631 3632 3633 3634
	  /* 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
3635 3636
				       NULL_TREE, false, !sym->attr.pointer,
				       callee_alloc, &se->ss->expr->where);
rsandifo's avatar
rsandifo committed
3637 3638

	  /* Pass the temporary as the first argument.  */
3639 3640
	  result = info->descriptor;
	  tmp = gfc_build_addr_expr (NULL_TREE, result);
froydnj's avatar
gcc/  
froydnj committed
3641
	  VEC_safe_push (tree, gc, retargs, tmp);
rsandifo's avatar
rsandifo committed
3642 3643 3644 3645
	}
      else if (ts.type == BT_CHARACTER)
	{
	  /* Pass the string length.  */
3646
	  type = gfc_get_character_type (ts.kind, ts.u.cl);
rsandifo's avatar
rsandifo committed
3647 3648 3649 3650
	  type = build_pointer_type (type);

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

3656 3657 3658 3659 3660 3661
	      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
3662
	      /* Provide an address expression for the function arguments.  */
3663
	      var = gfc_build_addr_expr (NULL_TREE, var);
rsandifo's avatar
rsandifo committed
3664 3665 3666 3667
	    }
	  else
	    var = gfc_conv_string_tmp (se, type, len);

froydnj's avatar
gcc/  
froydnj committed
3668
	  VEC_safe_push (tree, gc, retargs, var);
rsandifo's avatar
rsandifo committed
3669 3670 3671 3672 3673 3674
	}
      else
	{
	  gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);

	  type = gfc_get_complex_type (ts.kind);
3675
	  var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
froydnj's avatar
gcc/  
froydnj committed
3676
	  VEC_safe_push (tree, gc, retargs, var);
rsandifo's avatar
rsandifo committed
3677 3678
	}

3679 3680 3681 3682 3683 3684 3685 3686 3687
      if (ts.type == BT_CHARACTER && ts.deferred
	    && (sym->attr.allocatable || sym->attr.pointer))
	{
	  tmp = len;
	  if (TREE_CODE (tmp) != VAR_DECL)
	    tmp = gfc_evaluate_now (len, &se->pre);
	  len = gfc_build_addr_expr (NULL_TREE, tmp);
	}

rsandifo's avatar
rsandifo committed
3688 3689
      /* Add the string length to the argument list.  */
      if (ts.type == BT_CHARACTER)
froydnj's avatar
gcc/  
froydnj committed
3690
	VEC_safe_push (tree, gc, retargs, len);
rsandifo's avatar
rsandifo committed
3691
    }
rsandifo's avatar
rsandifo committed
3692
  gfc_free_interface_mapping (&mapping);
rsandifo's avatar
rsandifo committed
3693

froydnj's avatar
gcc/  
froydnj committed
3694 3695 3696 3697 3698
  /* 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
3699
  /* Add the return arguments.  */
froydnj's avatar
gcc/  
froydnj committed
3700
  VEC_splice (tree, retargs, arglist);
dnovillo's avatar
 
dnovillo committed
3701 3702

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

fxcoudert's avatar
fxcoudert committed
3705 3706
  /* 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
3707 3708 3709
  if (!VEC_empty (tree, append_args))
    VEC_splice (tree, retargs, append_args);
  arglist = retargs;
fxcoudert's avatar
fxcoudert committed
3710

dnovillo's avatar
 
dnovillo committed
3711
  /* Generate the actual call.  */
3712
  conv_function_val (se, sym, expr);
3713

dnovillo's avatar
 
dnovillo committed
3714
  /* If there are alternate return labels, function type should be
3715
     integer.  Can't modify the type in place though, since it can be shared
3716
     with other functions.  For dummy arguments, the typing is done to
mrs's avatar
mrs committed
3717
     this result, even if it has to be repeated for each call.  */
3718 3719 3720
  if (has_alternate_specifier
      && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
    {
3721 3722 3723 3724 3725
      if (!sym->attr.dummy)
	{
	  TREE_TYPE (sym->backend_decl)
		= build_function_type (integer_type_node,
		      TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3726
	  se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3727 3728 3729
	}
      else
	TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3730
    }
dnovillo's avatar
 
dnovillo committed
3731 3732

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

tobi's avatar
tobi committed
3735 3736 3737 3738
  /* 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.  */
3739
  if (!se->want_pointer && !byref
3740 3741 3742
      && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
	  || (comp && (comp->attr.pointer || comp->attr.allocatable))))
    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
tobi's avatar
tobi committed
3743

tobi's avatar
tobi committed
3744 3745 3746 3747 3748 3749 3750 3751 3752
  /* 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);

3753 3754
  /* A pure function may still have side-effects - it may modify its
     parameters.  */
dnovillo's avatar
 
dnovillo committed
3755 3756 3757 3758 3759 3760
  TREE_SIDE_EFFECTS (se->expr) = 1;
#if 0
  if (!sym->attr.pure)
    TREE_SIDE_EFFECTS (se->expr) = 1;
#endif

3761
  if (byref)
dnovillo's avatar
 
dnovillo committed
3762
    {
3763
      /* Add the function call to the pre chain.  There is no expression.  */
dnovillo's avatar
 
dnovillo committed
3764
      gfc_add_expr_to_block (&se->pre, se->expr);
3765
      se->expr = NULL_TREE;
dnovillo's avatar
 
dnovillo committed
3766

3767
      if (!se->direct_byref)
dnovillo's avatar
 
dnovillo committed
3768
	{
3769
	  if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
dnovillo's avatar
 
dnovillo committed
3770
	    {
3771
	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3772 3773 3774
		{
		  /* Check the data pointer hasn't been modified.  This would
		     happen in a function returning a pointer.  */
3775
		  tmp = gfc_conv_descriptor_data_get (info->descriptor);
3776 3777 3778
		  tmp = fold_build2_loc (input_location, NE_EXPR,
					 boolean_type_node,
					 tmp, info->data);
3779 3780
		  gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
					   gfc_msg_fault);
3781 3782
		}
	      se->expr = info->descriptor;
3783 3784
	      /* Bundle in the string length.  */
	      se->string_length = len;
dnovillo's avatar
 
dnovillo committed
3785
	    }
3786
	  else if (ts.type == BT_CHARACTER)
kazu's avatar
kazu committed
3787
	    {
3788
	      /* Dereference for character pointer results.  */
3789 3790 3791
	      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
3792
	      else
3793 3794
	        se->expr = var;

3795 3796 3797 3798
	      if (!ts.deferred)
		se->string_length = len;
	      else if (sym->attr.allocatable || sym->attr.pointer)
		se->string_length = cl.backend_decl;
3799 3800
	    }
	  else
tobi's avatar
tobi committed
3801
	    {
3802 3803
	      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
3804
	    }
dnovillo's avatar
 
dnovillo committed
3805 3806
	}
    }
3807

3808 3809
  /* Follow the function call with the argument post block.  */
  if (byref)
3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839
    {
      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);
	}
    }
3840 3841 3842
  else
    gfc_add_block_to_block (&se->post, &post);

3843
  return has_alternate_specifier;
dnovillo's avatar
 
dnovillo committed
3844 3845 3846
}


3847 3848 3849 3850 3851 3852 3853 3854 3855 3856
/* 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)
3857
    return build_call_expr_loc (input_location,
3858 3859
			    builtin_decl_explicit (BUILT_IN_MEMSET),
			    3, start,
3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871
			    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");
3872
  gfc_add_modify (&block, i, fold_convert (sizetype, size));
3873
  el = gfc_create_var (build_pointer_type (type), "el");
3874
  gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3875 3876 3877 3878 3879 3880 3881 3882
  exit_label = gfc_build_label_decl (NULL_TREE);
  TREE_USED (exit_label) = 1;


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

  /* Exit condition.  */
3883
  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
froydnj's avatar
gcc/  
froydnj committed
3884
			  build_zero_cst (sizetype));
3885
  tmp = build1_v (GOTO_EXPR, exit_label);
3886 3887
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
			 build_empty_stmt (input_location));
3888 3889 3890
  gfc_add_expr_to_block (&loop, tmp);

  /* Assignment.  */
3891 3892 3893
  gfc_add_modify (&loop,
		  fold_build1_loc (input_location, INDIRECT_REF, type, el),
		  build_int_cst (type, lang_hooks.to_target_charset (' ')));
3894 3895

  /* Increment loop variables.  */
3896 3897 3898 3899
  gfc_add_modify (&loop, i,
		  fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
				   TYPE_SIZE_UNIT (type)));
  gfc_add_modify (&loop, el,
3900 3901
		  fold_build_pointer_plus_loc (input_location,
					       el, TYPE_SIZE_UNIT (type)));
3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916

  /* 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
3917 3918
/* Generate code to copy a string.  */

3919
void
3920
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3921
		       int dkind, tree slength, tree src, int skind)
pbrook's avatar
pbrook committed
3922
{
3923
  tree tmp, dlen, slen;
fengwang's avatar
fengwang committed
3924 3925
  tree dsc;
  tree ssc;
fxcoudert's avatar
fxcoudert committed
3926
  tree cond;
fxcoudert's avatar
fxcoudert committed
3927 3928 3929 3930
  tree cond2;
  tree tmp2;
  tree tmp3;
  tree tmp4;
3931
  tree chartype;
fxcoudert's avatar
fxcoudert committed
3932
  stmtblock_t tempblock;
fengwang's avatar
fengwang committed
3933

3934 3935
  gcc_assert (dkind == skind);

3936 3937 3938
  if (slength != NULL_TREE)
    {
      slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3939
      ssc = gfc_string_to_single_character (slen, src, skind);
3940 3941 3942 3943 3944 3945 3946 3947 3948 3949
    }
  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));
3950
      dsc = gfc_string_to_single_character (dlen, dest, dkind);
3951 3952 3953 3954 3955 3956 3957
    }
  else
    {
      dlen = build_int_cst (size_type_node, 1);
      dsc =  dest;
    }

3958 3959
  /* Assign directly if the types are compatible.  */
  if (dsc != NULL_TREE && ssc != NULL_TREE
3960
      && TREE_TYPE (dsc) == TREE_TYPE (ssc))
fengwang's avatar
fengwang committed
3961
    {
3962
      gfc_add_modify (block, dsc, ssc);
fengwang's avatar
fengwang committed
3963 3964
      return;
    }
pbrook's avatar
pbrook committed
3965

fxcoudert's avatar
fxcoudert committed
3966
  /* Do nothing if the destination length is zero.  */
3967 3968
  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
			  build_int_cst (size_type_node, 0));
fxcoudert's avatar
fxcoudert committed
3969

fxcoudert's avatar
fxcoudert committed
3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991
  /* 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.  */
3992

3993 3994 3995
  /* For non-default character kinds, we have to multiply the string
     length by the base type size.  */
  chartype = gfc_get_char_type (dkind);
3996 3997 3998 3999 4000 4001 4002 4003
  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)));
4004

4005
  if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4006 4007 4008 4009
    dest = fold_convert (pvoid_type_node, dest);
  else
    dest = gfc_build_addr_expr (pvoid_type_node, dest);

4010
  if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4011 4012 4013
    src = fold_convert (pvoid_type_node, src);
  else
    src = gfc_build_addr_expr (pvoid_type_node, src);
4014

fxcoudert's avatar
fxcoudert committed
4015
  /* Truncate string if source is too long.  */
4016 4017
  cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
			   dlen);
4018
  tmp2 = build_call_expr_loc (input_location,
4019 4020
			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
			      3, dest, src, dlen);
fxcoudert's avatar
fxcoudert committed
4021 4022

  /* Else copy and pad with spaces.  */
4023
  tmp3 = build_call_expr_loc (input_location,
4024 4025
			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
			      3, dest, src, slen);
fxcoudert's avatar
fxcoudert committed
4026

4027
  tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4028
  tmp4 = fill_with_spaces (tmp4, chartype,
4029 4030
			   fold_build2_loc (input_location, MINUS_EXPR,
					    TREE_TYPE(dlen), dlen, slen));
fxcoudert's avatar
fxcoudert committed
4031 4032 4033 4034 4035 4036 4037

  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.  */
4038 4039 4040 4041
  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
4042 4043 4044 4045
  gfc_add_expr_to_block (block, tmp);
}


dnovillo's avatar
 
dnovillo committed
4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059
/* 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
4060 4061 4062 4063 4064
  gfc_saved_var *saved_vars;
  tree *temp_vars;
  tree type;
  tree tmp;
  int n;
dnovillo's avatar
 
dnovillo committed
4065 4066 4067 4068 4069 4070

  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
4071
  n = 0;
dnovillo's avatar
 
dnovillo committed
4072
  for (fargs = sym->formal; fargs; fargs = fargs->next)
pbrook's avatar
pbrook committed
4073
    n++;
4074 4075
  saved_vars = XCNEWVEC (gfc_saved_var, n);
  temp_vars = XCNEWVEC (tree, n);
pbrook's avatar
pbrook committed
4076 4077

  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
dnovillo's avatar
 
dnovillo committed
4078 4079 4080
    {
      /* Each dummy shall be specified, explicitly or implicitly, to be
         scalar.  */
pbrook's avatar
pbrook committed
4081
      gcc_assert (fargs->sym->attr.dimension == 0);
dnovillo's avatar
 
dnovillo committed
4082 4083
      fsym = fargs->sym;

pbrook's avatar
pbrook committed
4084
      if (fsym->ts.type == BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
4085
        {
pbrook's avatar
pbrook committed
4086
	  /* Copy string arguments.  */
4087
	  tree arglen;
dnovillo's avatar
 
dnovillo committed
4088

4089
	  gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4090
		      && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
dnovillo's avatar
 
dnovillo committed
4091

4092 4093 4094 4095
	  /* Create a temporary to hold the value.  */
          if (fsym->ts.u.cl->backend_decl == NULL_TREE)
	     fsym->ts.u.cl->backend_decl
		= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
dnovillo's avatar
 
dnovillo committed
4096

4097 4098 4099 4100 4101 4102 4103 4104 4105
	  type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
	  temp_vars[n] = gfc_create_var (type, fsym->name);

	  arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));

	  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);
dnovillo's avatar
 
dnovillo committed
4106

4107
	  gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4108
				 rse.string_length, rse.expr, fsym->ts.kind);
4109 4110
	  gfc_add_block_to_block (&se->pre, &lse.post);
	  gfc_add_block_to_block (&se->pre, &rse.post);
dnovillo's avatar
 
dnovillo committed
4111 4112 4113 4114
        }
      else
        {
          /* For everything else, just evaluate the expression.  */
4115 4116 4117 4118 4119

	  /* Create a temporary to hold the value.  */
	  type = gfc_typenode_for_spec (&fsym->ts);
	  temp_vars[n] = gfc_create_var (type, fsym->name);

dnovillo's avatar
 
dnovillo committed
4120 4121 4122
          gfc_conv_expr (&lse, args->expr);

          gfc_add_block_to_block (&se->pre, &lse.pre);
4123
          gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
dnovillo's avatar
 
dnovillo committed
4124 4125
          gfc_add_block_to_block (&se->pre, &lse.post);
        }
pbrook's avatar
pbrook committed
4126

dnovillo's avatar
 
dnovillo committed
4127 4128
      args = args->next;
    }
pbrook's avatar
pbrook committed
4129 4130 4131 4132 4133

  /* 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
4134
  gfc_conv_expr (se, sym->value);
pbrook's avatar
pbrook committed
4135 4136 4137

  if (sym->ts.type == BT_CHARACTER)
    {
4138
      gfc_conv_const_charlen (sym->ts.u.cl);
pbrook's avatar
pbrook committed
4139 4140 4141 4142

      /* Force the expression to the correct length.  */
      if (!INTEGER_CST_P (se->string_length)
	  || tree_int_cst_lt (se->string_length,
4143
			      sym->ts.u.cl->backend_decl))
pbrook's avatar
pbrook committed
4144
	{
4145
	  type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
pbrook's avatar
pbrook committed
4146 4147
	  tmp = gfc_create_var (type, sym->name);
	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4148
	  gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4149 4150
				 sym->ts.kind, se->string_length, se->expr,
				 sym->ts.kind);
pbrook's avatar
pbrook committed
4151 4152
	  se->expr = tmp;
	}
4153
      se->string_length = sym->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
4154 4155
    }

4156
  /* Restore the original variables.  */
pbrook's avatar
pbrook committed
4157 4158
  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    gfc_restore_sym (fargs->sym, &saved_vars[n]);
4159
  free (saved_vars);
dnovillo's avatar
 
dnovillo committed
4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175
}


/* 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;
    }

4176
  /* We distinguish statement functions from general functions to improve
dnovillo's avatar
 
dnovillo committed
4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188
     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;
4189

froydnj's avatar
gcc/  
froydnj committed
4190
  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
dnovillo's avatar
 
dnovillo committed
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
/* 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
4231 4232 4233
static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
pbrook's avatar
pbrook committed
4234 4235
  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
4236 4237 4238 4239 4240

  gfc_conv_tmp_array_ref (se);
}


4241
/* Build a static initializer.  EXPR is the expression for the initial value.
4242 4243
   The other parameters describe the variable of the component being 
   initialized. EXPR may be null.  */
dnovillo's avatar
 
dnovillo committed
4244

4245 4246
tree
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4247
		      bool array, bool pointer, bool procptr)
4248 4249 4250
{
  gfc_se se;

4251
  if (!(expr || pointer || procptr))
4252 4253
    return NULL_TREE;

4254 4255 4256 4257
  /* 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 *).  */
4258
  if (expr != NULL && expr->ts.type == BT_DERIVED
4259
      && expr->ts.is_iso_c && expr->ts.u.derived)
4260
    {
4261
      gfc_symbol *derived = expr->ts.u.derived;
4262 4263 4264

      /* The derived symbol has already been converted to a (void *).  Use
	 its kind.  */
4265
      expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4266
      expr->ts.f90_type = derived->ts.f90_type;
4267 4268 4269

      gfc_init_se (&se, NULL);
      gfc_conv_constant (&se, expr);
4270
      gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4271
      return se.expr;
4272
    }
4273
  
4274
  if (array && !procptr)
4275
    {
4276
      tree ctor;
4277 4278
      /* Arrays need special handling.  */
      if (pointer)
4279
	ctor = gfc_build_null_descriptor (type);
4280 4281
      /* Special case assigning an array to zero.  */
      else if (is_zero_initializer_p (expr))
4282
        ctor = build_constructor (type, NULL);
4283
      else
4284 4285 4286
	ctor = gfc_conv_array_initializer (type, expr);
      TREE_STATIC (ctor) = 1;
      return ctor;
4287
    }
4288
  else if (pointer || procptr)
4289 4290 4291 4292 4293 4294 4295 4296
    {
      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);
4297
          gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4298 4299 4300
	  return se.expr;
	}
    }
4301 4302 4303 4304 4305
  else
    {
      switch (ts->type)
	{
	case BT_DERIVED:
burnus's avatar
burnus committed
4306
	case BT_CLASS:
4307
	  gfc_init_se (&se, NULL);
4308 4309 4310 4311
	  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);
4312 4313
	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
	  TREE_STATIC (se.expr) = 1;
4314 4315 4316
	  return se.expr;

	case BT_CHARACTER:
4317 4318 4319 4320 4321
	  {
	    tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
	    TREE_STATIC (ctor) = 1;
	    return ctor;
	  }
4322 4323 4324 4325

	default:
	  gfc_init_se (&se, NULL);
	  gfc_conv_constant (&se, expr);
4326
	  gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4327 4328 4329 4330 4331
	  return se.expr;
	}
    }
}
  
pbrook's avatar
pbrook committed
4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355
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)
4356 4357
    /* The rhs is scalar.  Add a ss for the expression.  */
    rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
pbrook's avatar
pbrook committed
4358 4359

  /* Create a SS for the destination.  */
4360 4361
  lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
			  GFC_SS_COMPONENT);
pbrook's avatar
pbrook committed
4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384
  lss->shape = gfc_get_shape (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.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.  */
4385
  gfc_conv_loop_setup (&loop, &expr->where);
pbrook's avatar
pbrook committed
4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399

  /* 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);
4400
  if (cm->ts.type == BT_CHARACTER)
4401
    lse.string_length = cm->ts.u.cl->backend_decl;
4402

pbrook's avatar
pbrook committed
4403 4404
  gfc_conv_expr (&rse, expr);

4405
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
pbrook's avatar
pbrook committed
4406 4407
  gfc_add_expr_to_block (&body, tmp);

pbrook's avatar
pbrook committed
4408
  gcc_assert (rse.ss == gfc_ss_terminator);
pbrook's avatar
pbrook committed
4409 4410 4411 4412 4413 4414 4415 4416

  /* 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);

4417
  gcc_assert (lss->shape != NULL);
4418
  gfc_free_shape (&lss->shape, cm->as->rank);
pbrook's avatar
pbrook committed
4419 4420
  gfc_cleanup_loop (&loop);

pbrook's avatar
pbrook committed
4421 4422 4423
  return gfc_finish_block (&block);
}

4424

4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521
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]);
4522 4523 4524 4525
      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);
4526 4527 4528 4529 4530
      gfc_conv_descriptor_ubound_set (&block, dest,
				      gfc_rank_cst[n], tmp);
      gfc_conv_descriptor_lbound_set (&block, dest,
				      gfc_rank_cst[n], lbound);

4531
      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4532 4533 4534 4535 4536
			 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);
4537 4538
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
			     offset, tmp2);
4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557
      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);
4558 4559
	  tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
			    fold_convert (TREE_TYPE (tmp), null_pointer_node));
4560 4561 4562 4563 4564 4565 4566 4567 4568
	  return build3_v (COND_EXPR, tmp,
			   null_expr, non_null_expr);
	}
    }

  return gfc_finish_block (&block);
}


pbrook's avatar
pbrook committed
4569 4570 4571 4572 4573 4574
/* 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;
4575
  gfc_se lse;
pbrook's avatar
pbrook committed
4576 4577 4578 4579 4580
  gfc_ss *rss;
  stmtblock_t block;
  tree tmp;

  gfc_start_block (&block);
4581

4582
  if (cm->attr.pointer)
pbrook's avatar
pbrook committed
4583 4584 4585
    {
      gfc_init_se (&se, NULL);
      /* Pointer component.  */
4586
      if (cm->attr.dimension)
pbrook's avatar
pbrook committed
4587 4588 4589
	{
	  /* Array pointer.  */
	  if (expr->expr_type == EXPR_NULL)
4590
	    gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
pbrook's avatar
pbrook committed
4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606
	  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);
4607
	  gfc_add_modify (&block, dest,
pbrook's avatar
pbrook committed
4608 4609 4610 4611
			       fold_convert (TREE_TYPE (dest), se.expr));
	  gfc_add_block_to_block (&block, &se.post);
	}
    }
burnus's avatar
burnus committed
4612 4613 4614 4615
  else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
    {
      /* NULL initialization for CLASS components.  */
      tmp = gfc_trans_structure_assign (dest,
4616
					gfc_class_null_initializer (&cm->ts));
burnus's avatar
burnus committed
4617 4618
      gfc_add_expr_to_block (&block, tmp);
    }
4619
  else if (cm->attr.dimension && !cm->attr.proc_pointer)
pbrook's avatar
pbrook committed
4620
    {
4621
      if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4622
 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4623
      else if (cm->attr.allocatable)
4624
	{
4625
	  tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4626 4627
	  gfc_add_expr_to_block (&block, tmp);
	}
4628
      else
4629
	{
4630 4631
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
	  gfc_add_expr_to_block (&block, tmp);
4632
	}
pbrook's avatar
pbrook committed
4633 4634 4635
    }
  else if (expr->ts.type == BT_DERIVED)
    {
4636 4637 4638 4639
      if (expr->expr_type != EXPR_STRUCTURE)
	{
	  gfc_init_se (&se, NULL);
	  gfc_conv_expr (&se, expr);
4640
	  gfc_add_block_to_block (&block, &se.pre);
4641
	  gfc_add_modify (&block, dest,
4642
			       fold_convert (TREE_TYPE (dest), se.expr));
4643
	  gfc_add_block_to_block (&block, &se.post);
4644 4645 4646 4647 4648 4649 4650
	}
      else
	{
	  /* Nested constructors.  */
	  tmp = gfc_trans_structure_assign (dest, expr);
	  gfc_add_expr_to_block (&block, tmp);
	}
pbrook's avatar
pbrook committed
4651 4652 4653 4654 4655 4656 4657 4658 4659
    }
  else
    {
      /* Scalar component.  */
      gfc_init_se (&se, NULL);
      gfc_init_se (&lse, NULL);

      gfc_conv_expr (&se, expr);
      if (cm->ts.type == BT_CHARACTER)
4660
	lse.string_length = cm->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
4661
      lse.expr = dest;
4662
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
pbrook's avatar
pbrook committed
4663 4664 4665 4666 4667
      gfc_add_expr_to_block (&block, tmp);
    }
  return gfc_finish_block (&block);
}

4668
/* Assign a derived type constructor to a variable.  */
pbrook's avatar
pbrook committed
4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679

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);
4680
  cm = expr->ts.u.derived->components;
4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698

  if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
      && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
          || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
    {
      gfc_se se, lse;

      gcc_assert (cm->backend_decl == NULL);
      gfc_init_se (&se, NULL);
      gfc_init_se (&lse, NULL);
      gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
      lse.expr = dest;
      gfc_add_modify (&block, lse.expr,
		      fold_convert (TREE_TYPE (lse.expr), se.expr));

      return gfc_finish_block (&block);
    } 

4699 4700
  for (c = gfc_constructor_first (expr->value.constructor);
       c; c = gfc_constructor_next (c), cm = cm->next)
pbrook's avatar
pbrook committed
4701 4702 4703
    {
      /* Skip absent members in default initializers.  */
      if (!c->expr)
4704 4705
	continue;

pbrook's avatar
pbrook committed
4706
      field = cm->backend_decl;
4707 4708
      tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
			     dest, field, NULL_TREE);
pbrook's avatar
pbrook committed
4709 4710 4711 4712 4713 4714
      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
4715 4716 4717 4718 4719 4720 4721 4722 4723 4724
/* 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
4725
  tree tmp;
4726
  VEC(constructor_elt,gc) *v = NULL;
dnovillo's avatar
 
dnovillo committed
4727

pbrook's avatar
pbrook committed
4728 4729
  gcc_assert (se->ss == NULL);
  gcc_assert (expr->expr_type == EXPR_STRUCTURE);
dnovillo's avatar
 
dnovillo committed
4730
  type = gfc_typenode_for_spec (&expr->ts);
pbrook's avatar
pbrook committed
4731 4732 4733 4734

  if (!init)
    {
      /* Create a temporary variable and fill it in.  */
4735
      se->expr = gfc_create_var (type, expr->ts.u.derived->name);
pbrook's avatar
pbrook committed
4736 4737 4738 4739 4740
      tmp = gfc_trans_structure_assign (se->expr, expr);
      gfc_add_expr_to_block (&se->pre, tmp);
      return;
    }

4741
  cm = expr->ts.u.derived->components;
4742

4743 4744
  for (c = gfc_constructor_first (expr->value.constructor);
       c; c = gfc_constructor_next (c), cm = cm->next)
dnovillo's avatar
 
dnovillo committed
4745
    {
4746 4747 4748 4749
      /* 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.  */
4750
      if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
dnovillo's avatar
 
dnovillo committed
4751 4752
        continue;

4753
      if (strcmp (cm->name, "_size") == 0)
janus's avatar
janus committed
4754 4755 4756 4757 4758
	{
	  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
4759
	       && strcmp (cm->name, "_extends") == 0)
janus's avatar
janus committed
4760
	{
4761
	  tree vtab;
janus's avatar
janus committed
4762 4763
	  gfc_symbol *vtabs;
	  vtabs = cm->initializer->symtree->n.sym;
4764 4765
	  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
4766 4767 4768 4769
	}
      else
	{
	  val = gfc_conv_initializer (c->expr, &cm->ts,
4770 4771 4772
				      TREE_TYPE (cm->backend_decl),
				      cm->attr.dimension, cm->attr.pointer,
				      cm->attr.proc_pointer);
dnovillo's avatar
 
dnovillo committed
4773

burnus's avatar
burnus committed
4774 4775 4776
	  /* Append it to the constructor list.  */
	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
	}
dnovillo's avatar
 
dnovillo committed
4777
    }
4778
  se->expr = build_constructor (type, v);
4779
  if (init) 
4780
    TREE_CONSTANT (se->expr) = 1;
dnovillo's avatar
 
dnovillo committed
4781 4782 4783
}


4784
/* Translate a substring expression.  */
dnovillo's avatar
 
dnovillo committed
4785 4786 4787 4788 4789 4790 4791 4792

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

  ref = expr->ref;

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

4795 4796 4797
  se->expr = gfc_build_wide_string_const (expr->ts.kind,
					  expr->value.character.length,
					  expr->value.character.string);
4798

dnovillo's avatar
 
dnovillo committed
4799
  se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
fxcoudert's avatar
fxcoudert committed
4800
  TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
dnovillo's avatar
 
dnovillo committed
4801

fxcoudert's avatar
fxcoudert committed
4802 4803
  if (ref)
    gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
dnovillo's avatar
 
dnovillo committed
4804 4805 4806
}


4807 4808 4809
/* 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
4810 4811 4812 4813 4814 4815 4816

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
4817
      /* Substitute a scalar expression evaluated outside the scalarization
dnovillo's avatar
 
dnovillo committed
4818 4819
         loop.  */
      se->expr = se->ss->data.scalar.expr;
4820 4821
      if (se->ss->type == GFC_SS_REFERENCE)
	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
pbrook's avatar
pbrook committed
4822
      se->string_length = se->ss->string_length;
dnovillo's avatar
 
dnovillo committed
4823 4824 4825 4826
      gfc_advance_se_ss_chain (se);
      return;
    }

4827 4828 4829 4830 4831
  /* 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 *).  */
4832 4833
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->attr.is_iso_c)
4834
    {
4835 4836 4837 4838
      if (expr->expr_type == EXPR_VARIABLE
	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
	      || expr->symtree->n.sym->intmod_sym_id
		 == ISOCBINDING_NULL_FUNPTR))
4839 4840 4841 4842 4843 4844 4845 4846 4847
        {
	  /* 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.  */
4848 4849 4850
          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;
4851 4852 4853
        }
    }
  
dnovillo's avatar
 
dnovillo committed
4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888
  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
4889
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
4890 4891 4892 4893
      break;
    }
}

4894 4895
/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
   of an assignment.  */
dnovillo's avatar
 
dnovillo committed
4896 4897 4898 4899
void
gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
{
  gfc_conv_expr (se, expr);
4900
  /* All numeric lvalues should have empty post chains.  If not we need to
dnovillo's avatar
 
dnovillo committed
4901
     figure out a way of rewriting an lvalue so that it has no post chain.  */
4902
  gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
dnovillo's avatar
 
dnovillo committed
4903 4904
}

4905
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
jakub's avatar
jakub committed
4906
   numeric expressions.  Used for scalar values where inserting cleanup code
4907
   is inconvenient.  */
dnovillo's avatar
 
dnovillo committed
4908 4909 4910 4911 4912
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
{
  tree val;

pbrook's avatar
pbrook committed
4913
  gcc_assert (expr->ts.type != BT_CHARACTER);
dnovillo's avatar
 
dnovillo committed
4914 4915 4916 4917
  gfc_conv_expr (se, expr);
  if (se->post.head)
    {
      val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4918
      gfc_add_modify (&se->pre, val, se->expr);
4919 4920
      se->expr = val;
      gfc_add_block_to_block (&se->pre, &se->post);
dnovillo's avatar
 
dnovillo committed
4921 4922 4923
    }
}

4924
/* Helper to translate an expression and convert it to a particular type.  */
dnovillo's avatar
 
dnovillo committed
4925 4926 4927 4928 4929 4930 4931 4932
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);
}


4933
/* Converts an expression so that it can be passed by reference.  Scalar
dnovillo's avatar
 
dnovillo committed
4934 4935 4936 4937 4938 4939 4940 4941 4942 4943
   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)
    {
4944 4945 4946
      /* Returns a reference to the scalar evaluated outside the loop
	 for this case.  */
      gfc_conv_expr (se, expr);
dnovillo's avatar
 
dnovillo committed
4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963
      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);
4964
	  gfc_add_modify (&se->pre, var, se->expr);
dnovillo's avatar
 
dnovillo committed
4965 4966 4967 4968 4969 4970
	  gfc_add_block_to_block (&se->pre, &se->post);
	  se->expr = var;
	}
      return;
    }

4971
  if (expr->expr_type == EXPR_FUNCTION
4972 4973 4974 4975 4976 4977
      && ((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)))
4978 4979 4980 4981
    {
      se->want_pointer = 1;
      gfc_conv_expr (se, expr);
      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4982
      gfc_add_modify (&se->pre, var, se->expr);
4983 4984 4985 4986 4987
      se->expr = var;
      return;
    }


dnovillo's avatar
 
dnovillo committed
4988 4989 4990
  gfc_conv_expr (se, expr);

  /* Create a temporary var to hold the value.  */
4991 4992
  if (TREE_CONSTANT (se->expr))
    {
4993 4994
      tree tmp = se->expr;
      STRIP_TYPE_NOPS (tmp);
aldyh's avatar
aldyh committed
4995 4996
      var = build_decl (input_location,
			CONST_DECL, NULL, TREE_TYPE (tmp));
4997
      DECL_INITIAL (var) = tmp;
4998
      TREE_STATIC (var) = 1;
4999 5000 5001 5002 5003
      pushdecl (var);
    }
  else
    {
      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5004
      gfc_add_modify (&se->pre, var, se->expr);
5005
    }
dnovillo's avatar
 
dnovillo committed
5006 5007 5008
  gfc_add_block_to_block (&se->pre, &se->post);

  /* Take the address of that value.  */
5009
  se->expr = gfc_build_addr_expr (NULL_TREE, var);
dnovillo's avatar
 
dnovillo committed
5010 5011 5012 5013 5014 5015
}


tree
gfc_trans_pointer_assign (gfc_code * code)
{
5016
  return gfc_trans_pointer_assignment (code->expr1, code->expr2);
dnovillo's avatar
 
dnovillo committed
5017 5018 5019
}


5020 5021
/* Generate code for a pointer assignment.  */

dnovillo's avatar
 
dnovillo committed
5022 5023 5024 5025 5026 5027 5028 5029
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
5030 5031
  tree desc;
  tree tmp;
5032 5033
  tree decl;

dnovillo's avatar
 
dnovillo committed
5034 5035 5036 5037 5038 5039 5040 5041
  gfc_start_block (&block);

  gfc_init_se (&lse, NULL);

  lss = gfc_walk_expr (expr1);
  rss = gfc_walk_expr (expr2);
  if (lss == gfc_ss_terminator)
    {
5042
      /* Scalar pointers.  */
dnovillo's avatar
 
dnovillo committed
5043 5044
      lse.want_pointer = 1;
      gfc_conv_expr (&lse, expr1);
pbrook's avatar
pbrook committed
5045
      gcc_assert (rss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5046 5047 5048
      gfc_init_se (&rse, NULL);
      rse.want_pointer = 1;
      gfc_conv_expr (&rse, expr2);
5049 5050 5051

      if (expr1->symtree->n.sym->attr.proc_pointer
	  && expr1->symtree->n.sym->attr.dummy)
5052 5053
	lse.expr = build_fold_indirect_ref_loc (input_location,
					    lse.expr);
5054

5055 5056
      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
	  && expr2->symtree->n.sym->attr.dummy)
5057 5058
	rse.expr = build_fold_indirect_ref_loc (input_location,
					    rse.expr);
5059

dnovillo's avatar
 
dnovillo committed
5060 5061
      gfc_add_block_to_block (&block, &lse.pre);
      gfc_add_block_to_block (&block, &rse.pre);
domob's avatar
domob committed
5062 5063

      /* Check character lengths if character expression.  The test is only
5064 5065
	 really added if -fbounds-check is enabled.  Exclude deferred
	 character length lefthand sides.  */
5066
      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5067 5068
	  && !(expr1->ts.deferred
			&& (TREE_CODE (lse.string_length) == VAR_DECL))
5069 5070
	  && !expr1->symtree->n.sym->attr.proc_pointer
	  && !gfc_is_proc_ptr_comp (expr1, NULL))
domob's avatar
domob committed
5071 5072 5073 5074 5075 5076 5077 5078
	{
	  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);
	}

5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089
      /* The assignment to an deferred character length sets the string
	 length to that of the rhs.  */
      if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
	{
	  if (expr2->expr_type != EXPR_NULL)
	    gfc_add_modify (&block, lse.string_length, rse.string_length);
	  else
	    gfc_add_modify (&block, lse.string_length,
			    build_int_cst (gfc_charlen_type_node, 0));
	}

5090
      gfc_add_modify (&block, lse.expr,
5091
			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
domob's avatar
domob committed
5092

dnovillo's avatar
 
dnovillo committed
5093 5094 5095 5096 5097
      gfc_add_block_to_block (&block, &rse.post);
      gfc_add_block_to_block (&block, &lse.post);
    }
  else
    {
domob's avatar
domob committed
5098 5099
      gfc_ref* remap;
      bool rank_remap;
domob's avatar
domob committed
5100 5101 5102
      tree strlen_lhs;
      tree strlen_rhs = NULL_TREE;

domob's avatar
domob committed
5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115
      /* 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
5116
      gfc_conv_expr_descriptor (&lse, expr1, lss);
domob's avatar
domob committed
5117
      strlen_lhs = lse.string_length;
domob's avatar
domob committed
5118 5119 5120
      desc = lse.expr;

      if (expr2->expr_type == EXPR_NULL)
rsandifo's avatar
rsandifo committed
5121 5122
	{
	  /* Just set the data pointer to null.  */
5123
	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
domob's avatar
domob committed
5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137
	}
      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
5138
	  lse.direct_byref = 1;
rsandifo's avatar
rsandifo committed
5139
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
domob's avatar
domob committed
5140
	  strlen_rhs = lse.string_length;
5141 5142

	  /* If this is a subreference array pointer assignment, use the rhs
5143
	     descriptor element size for the lhs span.  */
5144 5145 5146
	  if (expr1->symtree->n.sym->attr.subref_array_pointer)
	    {
	      decl = expr1->symtree->n.sym->backend_decl;
5147 5148 5149 5150 5151 5152
	      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
5153
		gfc_add_block_to_block (&lse.post, &rse.pre);
5154
	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5155
	    }
domob's avatar
domob committed
5156 5157 5158
	}
      else
	{
rsandifo's avatar
rsandifo committed
5159 5160 5161 5162 5163 5164 5165
	  /* 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
5166
	  strlen_rhs = lse.string_length;
5167
	  gfc_add_modify (&lse.pre, desc, tmp);
domob's avatar
domob committed
5168 5169
	}

dnovillo's avatar
 
dnovillo committed
5170
      gfc_add_block_to_block (&block, &lse.pre);
domob's avatar
domob committed
5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207
      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]);
5208 5209 5210 5211
		  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
5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256
		}
	      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);
5257 5258 5259 5260
		  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
5261 5262 5263 5264 5265
		  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);
5266 5267
		  stride = fold_build2_loc (input_location, MULT_EXPR,
					    gfc_array_index_type, stride, tmp);
domob's avatar
domob committed
5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291
		}
	    }
	  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
5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302

      /* 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
5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315
      /* 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);
5316 5317
	  fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
				   rsize, lsize);
domob's avatar
domob committed
5318 5319 5320 5321 5322 5323

	  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
5324
      gfc_add_block_to_block (&block, &lse.post);
domob's avatar
domob committed
5325 5326
      if (rank_remap)
	gfc_add_block_to_block (&block, &rse.post);
dnovillo's avatar
 
dnovillo committed
5327
    }
domob's avatar
domob committed
5328

dnovillo's avatar
 
dnovillo committed
5329 5330 5331 5332 5333
  return gfc_finish_block (&block);
}


/* Makes sure se is suitable for passing as a function string parameter.  */
rwild's avatar
rwild committed
5334
/* TODO: Need to check all callers of this function.  It may be abused.  */
dnovillo's avatar
 
dnovillo committed
5335 5336 5337 5338 5339 5340 5341 5342

void
gfc_conv_string_parameter (gfc_se * se)
{
  tree type;

  if (TREE_CODE (se->expr) == STRING_CST)
    {
5343 5344
      type = TREE_TYPE (TREE_TYPE (se->expr));
      se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
dnovillo's avatar
 
dnovillo committed
5345 5346 5347
      return;
    }

5348
  if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
dnovillo's avatar
 
dnovillo committed
5349
    {
5350
      if (TREE_CODE (se->expr) != INDIRECT_REF)
5351 5352 5353 5354
	{
	  type = TREE_TYPE (se->expr);
          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
	}
5355 5356 5357 5358 5359 5360 5361
      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
5362 5363
    }

pbrook's avatar
pbrook committed
5364
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
dnovillo's avatar
 
dnovillo committed
5365 5366 5367 5368
}


/* Generate code for assignment of scalar variables.  Includes character
5369 5370
   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
5371 5372

tree
5373
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5374
			 bool l_is_temp, bool r_is_var, bool dealloc)
dnovillo's avatar
 
dnovillo committed
5375 5376
{
  stmtblock_t block;
5377 5378
  tree tmp;
  tree cond;
dnovillo's avatar
 
dnovillo committed
5379 5380 5381

  gfc_init_block (&block);

5382
  if (ts.type == BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
5383
    {
5384 5385
      tree rlen = NULL;
      tree llen = NULL;
dnovillo's avatar
 
dnovillo committed
5386

5387 5388 5389 5390 5391 5392
      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
5393

5394 5395 5396 5397 5398 5399 5400
      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
5401

5402 5403
      gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
			     rse->expr, ts.kind);
dnovillo's avatar
 
dnovillo committed
5404
    }
5405
  else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5406 5407 5408 5409 5410 5411
    {
      cond = NULL_TREE;
	
      /* Are the rhs and the lhs the same?  */
      if (r_is_var)
	{
5412 5413 5414
	  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));
5415 5416 5417 5418
	  cond = gfc_evaluate_now (cond, &lse->pre);
	}

      /* Deallocate the lhs allocated components as long as it is not
5419 5420 5421
	 the same as the rhs.  This must be done following the assignment
	 to prevent deallocating data that could be used in the rhs
	 expression.  */
5422
      if (!l_is_temp && dealloc)
5423
	{
5424
	  tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5425
	  tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5426
	  if (r_is_var)
aldyh's avatar
aldyh committed
5427 5428
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
			    tmp);
5429
	  gfc_add_expr_to_block (&lse->post, tmp);
5430
	}
5431

5432 5433
      gfc_add_block_to_block (&block, &rse->pre);
      gfc_add_block_to_block (&block, &lse->pre);
5434

5435
      gfc_add_modify (&block, lse->expr,
5436 5437 5438
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));

      /* Do a deep copy if the rhs is a variable, if it is not the
5439
	 same as the lhs.  */
5440 5441
      if (r_is_var)
	{
5442
	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
aldyh's avatar
aldyh committed
5443 5444
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
			  tmp);
5445 5446 5447
	  gfc_add_expr_to_block (&block, tmp);
	}
    }
5448
  else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5449 5450 5451
    {
      gfc_add_block_to_block (&block, &lse->pre);
      gfc_add_block_to_block (&block, &rse->pre);
5452 5453
      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
			     TREE_TYPE (lse->expr), rse->expr);
5454 5455
      gfc_add_modify (&block, lse->expr, tmp);
    }
dnovillo's avatar
 
dnovillo committed
5456 5457 5458 5459 5460
  else
    {
      gfc_add_block_to_block (&block, &lse->pre);
      gfc_add_block_to_block (&block, &rse->pre);

5461
      gfc_add_modify (&block, lse->expr,
5462
		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
dnovillo's avatar
 
dnovillo committed
5463 5464 5465 5466 5467 5468 5469 5470 5471
    }

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

  return gfc_finish_block (&block);
}


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

5475 5476
static bool
arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
dnovillo's avatar
 
dnovillo committed
5477
{
5478 5479
  gfc_ref * ref;
  bool seen_array_ref;
5480
  bool c = false;
5481
  gfc_symbol *sym = expr1->symtree->n.sym;
dnovillo's avatar
 
dnovillo committed
5482 5483 5484

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

5487 5488 5489
  /* 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
5490 5491
  if (expr2->value.function.esym != NULL
      && expr2->value.function.esym->attr.elemental)
5492
    return true;
dnovillo's avatar
 
dnovillo committed
5493

5494
  /* Need a temporary if rhs is not FULL or a contiguous section.  */
5495
  if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5496
    return true;
5497

5498
  /* Need a temporary if EXPR1 can't be expressed as a descriptor.  */
rsandifo's avatar
rsandifo committed
5499
  if (gfc_ref_needs_temporary_p (expr1->ref))
5500
    return true;
rsandifo's avatar
rsandifo committed
5501

burnus's avatar
burnus committed
5502 5503 5504 5505 5506 5507 5508
  /* Functions returning pointers or allocatables need temporaries.  */
  c = expr2->value.function.esym
      ? (expr2->value.function.esym->attr.pointer 
	 || expr2->value.function.esym->attr.allocatable)
      : (expr2->symtree->n.sym->attr.pointer
	 || expr2->symtree->n.sym->attr.allocatable);
  if (c)
5509
    return true;
eedelman's avatar
eedelman committed
5510

5511 5512 5513 5514
  /* Character array functions need temporaries unless the
     character lengths are the same.  */
  if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
    {
5515 5516
      if (expr1->ts.u.cl->length == NULL
	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5517
	return true;
5518

5519 5520
      if (expr2->ts.u.cl->length == NULL
	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5521
	return true;
5522

5523 5524
      if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
		     expr2->ts.u.cl->length->value.integer) != 0)
5525
	return true;
5526 5527
    }

5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538
  /* 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)
5539
	return true;
5540 5541
    }

dnovillo's avatar
 
dnovillo committed
5542
  /* Check for a dependency.  */
rsandifo's avatar
rsandifo committed
5543 5544
  if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
				   expr2->value.function.esym,
5545 5546
				   expr2->value.function.actual,
				   NOT_ELEMENTAL))
5547 5548 5549
    return true;

  /* If we have reached here with an intrinsic function, we do not
5550 5551
     need a temporary except in the particular case that reallocation
     on assignment is active and the lhs is allocatable and a target.  */
5552
  if (expr2->value.function.isym)
5553 5554 5555
    return (gfc_option.flag_realloc_lhs
	      && sym->attr.allocatable
	      && sym->attr.target);
5556 5557 5558 5559 5560 5561

  /* 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;

5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573
  /* If the lhs has been host_associated, is in common, a pointer or is
     a target and the function is not using a RESULT variable, aliasing
     can occur and a temporary is needed.  */
  if ((sym->attr.host_assoc
	   || sym->attr.in_common
	   || sym->attr.pointer
	   || sym->attr.cray_pointee
	   || sym->attr.target)
	&& expr2->symtree != NULL
	&& expr2->symtree->n.sym == expr2->symtree->n.sym->result)
    return true;

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

5579 5580 5581 5582 5583
  /* Implicit_pure functions are those which could legally be declared
     to be PURE.  */
  if (expr2->value.function.esym != NULL
      && expr2->value.function.esym->attr.implicit_pure)
    return false;
5584 5585 5586 5587 5588

  if (!sym->attr.use_assoc
	&& !sym->attr.in_common
	&& !sym->attr.pointer
	&& !sym->attr.target
5589
	&& !sym->attr.cray_pointee
5590 5591 5592 5593 5594 5595 5596 5597
	&& 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;

5598 5599 5600 5601 5602
      /* 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;

5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614
      /* 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;
}


5615 5616 5617 5618
/* Provide the loop info so that the lhs descriptor can be built for
   reallocatable assignments from extrinsic function calls.  */

static void
matz's avatar
matz committed
5619 5620
realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
			       gfc_loopinfo *loop)
5621 5622 5623 5624
{
  /* Signal that the function call should not be made by
     gfc_conv_loop_setup. */
  se->ss->is_alloc_lhs = 1;
matz's avatar
matz committed
5625 5626 5627 5628 5629 5630 5631 5632
  gfc_init_loopinfo (loop);
  gfc_add_ss_to_loop (loop, *ss);
  gfc_add_ss_to_loop (loop, se->ss);
  gfc_conv_ss_startstride (loop);
  gfc_conv_loop_setup (loop, where);
  gfc_copy_loopinfo_to_se (se, loop);
  gfc_add_block_to_block (&se->pre, &loop->pre);
  gfc_add_block_to_block (&se->pre, &loop->post);
5633 5634 5635 5636
  se->ss->is_alloc_lhs = 0;
}


5637 5638 5639 5640 5641 5642 5643
/* For Assignment to a reallocatable lhs from intrinsic functions,
   replace the se.expr (ie. the result) with a temporary descriptor.
   Null the data field so that the library allocates space for the
   result. Free the data of the original descriptor after the function,
   in case it appears in an argument expression and transfer the
   result to the original descriptor.  */

5644
static void
5645
fcncall_realloc_result (gfc_se *se, int rank)
5646 5647
{
  tree desc;
5648
  tree res_desc;
5649
  tree tmp;
5650 5651
  tree offset;
  int n;
5652

5653 5654
  /* Use the allocation done by the library.  Substitute the lhs
     descriptor with a copy, whose data field is nulled.*/
5655
  desc = build_fold_indirect_ref_loc (input_location, se->expr);
5656 5657 5658
  /* Unallocated, the descriptor does not have a dtype.  */
  tmp = gfc_conv_descriptor_dtype (desc);
  gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5659 5660 5661 5662
  res_desc = gfc_evaluate_now (desc, &se->pre);
  gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
  se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);

5663 5664
  /* Free the lhs after the function call and copy the result to
     the lhs descriptor.  */
5665 5666
  tmp = gfc_conv_descriptor_data_get (desc);
  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5667
  gfc_add_expr_to_block (&se->post, tmp);
5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700
  gfc_add_modify (&se->post, desc, res_desc);

  offset = gfc_index_zero_node;
  tmp = gfc_index_one_node;
  /* Now reset the bounds from zero based to unity based.  */
  for (n = 0 ; n < rank; n++)
    {
      /* Accumulate the offset.  */
      offset = fold_build2_loc (input_location, MINUS_EXPR,
				gfc_array_index_type,
				offset, tmp);
      /* Now do the bounds.  */
      gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
      tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
      tmp = fold_build2_loc (input_location, PLUS_EXPR,
			     gfc_array_index_type,
			     tmp, gfc_index_one_node);
      gfc_conv_descriptor_lbound_set (&se->post, desc,
				      gfc_rank_cst[n],
				      gfc_index_one_node);
      gfc_conv_descriptor_ubound_set (&se->post, desc,
				      gfc_rank_cst[n], tmp);

      /* The extent for the next contribution to offset.  */
      tmp = fold_build2_loc (input_location, MINUS_EXPR,
			     gfc_array_index_type,
			     gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
			     gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
      tmp = fold_build2_loc (input_location, PLUS_EXPR,
			     gfc_array_index_type,
			     tmp, gfc_index_one_node);
    }
  gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5701 5702 5703 5704
}



5705 5706 5707 5708 5709 5710 5711 5712 5713 5714
/* 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;
matz's avatar
matz committed
5715
  gfc_loopinfo loop;
5716 5717

  if (arrayfunc_assign_needs_temporary (expr1, expr2))
dnovillo's avatar
 
dnovillo committed
5718 5719 5720 5721
    return NULL;

  /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
     functions.  */
pbrook's avatar
pbrook committed
5722
  gcc_assert (expr2->value.function.isym
5723
	      || (gfc_is_proc_ptr_comp (expr2, &comp)
5724
		  && comp && comp->attr.dimension)
5725
	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5726
		  && expr2->value.function.esym->result->attr.dimension));
dnovillo's avatar
 
dnovillo committed
5727 5728

  ss = gfc_walk_expr (expr1);
pbrook's avatar
pbrook committed
5729
  gcc_assert (ss != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5730 5731 5732 5733
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  se.want_pointer = 1;

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

5736 5737 5738 5739 5740 5741 5742 5743 5744
  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
5745 5746
  se.direct_byref = 1;
  se.ss = gfc_walk_expr (expr2);
pbrook's avatar
pbrook committed
5747
  gcc_assert (se.ss != gfc_ss_terminator);
5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765

  /* Reallocate on assignment needs the loopinfo for extrinsic functions.
     This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
     Clearly, this cannot be done for an allocatable function result, since
     the shape of the result is unknown and, in any case, the function must
     correctly take care of the reallocation internally. For intrinsic
     calls, the array data is freed and the library takes care of allocation.
     TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
     to the library.  */    
  if (gfc_option.flag_realloc_lhs
	&& gfc_is_reallocatable_lhs (expr1)
	&& !gfc_expr_attr (expr1).codimension
	&& !gfc_is_coindexed (expr1)
	&& !(expr2->value.function.esym
	    && expr2->value.function.esym->result->attr.allocatable))
    {
      if (!expr2->value.function.isym)
	{
matz's avatar
matz committed
5766
	  realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5767 5768 5769
	  ss->is_alloc_lhs = 1;
	}
      else
5770
	fcncall_realloc_result (&se, expr1->rank);
5771 5772
    }

dnovillo's avatar
 
dnovillo committed
5773 5774 5775 5776 5777 5778
  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
5779 5780 5781 5782 5783 5784 5785 5786

/* 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;
5787
  tree tmp;
sayle's avatar
 
sayle committed
5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803
  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
5804
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5805 5806
  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
5807

5808 5809
  /* If we are zeroing a local array avoid taking its address by emitting
     a = {} instead.  */
sayle's avatar
 
sayle committed
5810
  if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5811 5812
    return build2_loc (input_location, MODIFY_EXPR, void_type_node,
		       dest, build_constructor (TREE_TYPE (dest), NULL));
5813 5814 5815

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

  /* Construct call to __builtin_memset.  */
5819
  tmp = build_call_expr_loc (input_location,
5820 5821
			     builtin_decl_explicit (BUILT_IN_MEMSET),
			     3, dest, integer_zero_node, len);
sayle's avatar
 
sayle committed
5822 5823
  return fold_convert (void_type_node, tmp);
}
dnovillo's avatar
 
dnovillo committed
5824

sayle's avatar
 
sayle committed
5825 5826 5827 5828

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

domob's avatar
domob committed
5829
tree
sayle's avatar
 
sayle committed
5830 5831
gfc_build_memcpy_call (tree dst, tree src, tree len)
{
5832
  tree tmp;
sayle's avatar
 
sayle committed
5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847

  /* 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.  */
5848
  tmp = build_call_expr_loc (input_location,
5849 5850
			     builtin_decl_explicit (BUILT_IN_MEMCPY),
			     3, dst, src, len);
sayle's avatar
 
sayle committed
5851 5852 5853 5854
  return fold_convert (void_type_node, tmp);
}


sayle's avatar
 
sayle committed
5855 5856 5857 5858
/* 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
5859

sayle's avatar
 
sayle committed
5860 5861 5862 5863 5864
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
5865
  tree tmp;
sayle's avatar
 
sayle committed
5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883

  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
5884
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5885 5886
  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
5887 5888 5889 5890

  slen = GFC_TYPE_ARRAY_SIZE (stype);
  if (!slen || TREE_CODE (slen) != INTEGER_CST)
    return NULL_TREE;
fxcoudert's avatar
fxcoudert committed
5891
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5892 5893
  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
5894 5895 5896 5897 5898 5899

  /* 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
5900 5901
  return gfc_build_memcpy_call (dst, src, dlen);
}
sayle's avatar
 
sayle committed
5902 5903


sayle's avatar
 
sayle committed
5904 5905 5906
/* 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
5907

sayle's avatar
 
sayle committed
5908 5909 5910 5911 5912 5913 5914
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
5915
  tree tmp;
sayle's avatar
 
sayle committed
5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936

  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
5937
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5938 5939
  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
5940 5941 5942 5943 5944 5945 5946 5947 5948

  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
5949 5950 5951
}


5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972
/* 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;
}


5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060
/* Is the lhs OK for automatic reallocation?  */

static bool
is_scalar_reallocatable_lhs (gfc_expr *expr)
{
  gfc_ref * ref;

  /* An allocatable variable with no reference.  */
  if (expr->symtree->n.sym->attr.allocatable
	&& !expr->ref)
    return true;

  /* All that can be left are allocatable components.  */
  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
	&& expr->symtree->n.sym->ts.type != BT_CLASS)
	|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
    return false;

  /* Find an allocatable component ref last.  */
  for (ref = expr->ref; ref; ref = ref->next)
    if (ref->type == REF_COMPONENT
	  && !ref->next
	  && ref->u.c.component->attr.allocatable)
      return true;

  return false;
}


/* Allocate or reallocate scalar lhs, as necessary.  */

static void
alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
					 tree string_length,
					 gfc_expr *expr1,
					 gfc_expr *expr2)

{
  tree cond;
  tree tmp;
  tree size;
  tree size_in_bytes;
  tree jump_label1;
  tree jump_label2;
  gfc_se lse;

  if (!expr1 || expr1->rank)
    return;

  if (!expr2 || expr2->rank)
    return;

  /* Since this is a scalar lhs, we can afford to do this.  That is,
     there is no risk of side effects being repeated.  */
  gfc_init_se (&lse, NULL);
  lse.want_pointer = 1;
  gfc_conv_expr (&lse, expr1);
  
  jump_label1 = gfc_build_label_decl (NULL_TREE);
  jump_label2 = gfc_build_label_decl (NULL_TREE);

  /* Do the allocation if the lhs is NULL. Otherwise go to label 1.  */
  tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
			  lse.expr, tmp);
  tmp = build3_v (COND_EXPR, cond,
		  build1_v (GOTO_EXPR, jump_label1),
		  build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
    {
      /* Use the rhs string length and the lhs element size.  */
      size = string_length;
      tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
      tmp = TYPE_SIZE_UNIT (tmp);
      size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
				       TREE_TYPE (tmp), tmp,
				       fold_convert (TREE_TYPE (tmp), size));
    }
  else
    {
      /* Otherwise use the length in bytes of the rhs.  */
      size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
      size_in_bytes = size;
    }

  tmp = build_call_expr_loc (input_location,
6061 6062
			     builtin_decl_explicit (BUILT_IN_MALLOC),
			     1, size_in_bytes);
6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087
  tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
  gfc_add_modify (block, lse.expr, tmp);
  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
    {
      /* Deferred characters need checking for lhs and rhs string
	 length.  Other deferred parameter variables will have to
	 come here too.  */
      tmp = build1_v (GOTO_EXPR, jump_label2);
      gfc_add_expr_to_block (block, tmp);
    }
  tmp = build1_v (LABEL_EXPR, jump_label1);
  gfc_add_expr_to_block (block, tmp);

  /* For a deferred length character, reallocate if lengths of lhs and
     rhs are different.  */
  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
    {
      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
			      expr1->ts.u.cl->backend_decl, size);
      /* Jump past the realloc if the lengths are the same.  */
      tmp = build3_v (COND_EXPR, cond,
		      build1_v (GOTO_EXPR, jump_label2),
		      build_empty_stmt (input_location));
      gfc_add_expr_to_block (block, tmp);
      tmp = build_call_expr_loc (input_location,
6088 6089
				 builtin_decl_explicit (BUILT_IN_REALLOC),
				 2, fold_convert (pvoid_type_node, lse.expr),
6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102
				 size_in_bytes);
      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
      gfc_add_modify (block, lse.expr, tmp);
      tmp = build1_v (LABEL_EXPR, jump_label2);
      gfc_add_expr_to_block (block, tmp);

      /* Update the lhs character length.  */
      size = string_length;
      gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
    }
}


sayle's avatar
 
sayle committed
6103
/* Subroutine of gfc_trans_assignment that actually scalarizes the
6104 6105 6106
   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
6107 6108

static tree
6109 6110
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
			bool dealloc)
dnovillo's avatar
 
dnovillo committed
6111 6112 6113 6114 6115 6116 6117 6118 6119 6120
{
  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;
6121
  bool l_is_temp;
6122
  bool scalar_to_array;
6123
  bool def_clen_func;
6124
  tree string_length;
6125
  int n;
dnovillo's avatar
 
dnovillo committed
6126 6127 6128 6129 6130 6131 6132 6133 6134

  /* 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);
6135 6136 6137 6138
  if (gfc_is_reallocatable_lhs (expr1)
	&& !(expr2->expr_type == EXPR_FUNCTION
	     && expr2->value.function.isym != NULL))
    lss->is_alloc_lhs = 1;
dnovillo's avatar
 
dnovillo committed
6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149
  rss = NULL;
  if (lss != gfc_ss_terminator)
    {
      /* 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
6150
      gcc_assert (lss_section != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
6151 6152 6153 6154 6155 6156 6157

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

      /* Walk the rhs.  */
      rss = gfc_walk_expr (expr2);
      if (rss == gfc_ss_terminator)
6158 6159 6160
	/* The rhs is scalar.  Add a ss for the expression.  */
	rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);

dnovillo's avatar
 
dnovillo committed
6161 6162 6163 6164 6165 6166
      /* 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);
6167
      /* Enable loop reversal.  */
6168 6169
      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
	loop.reverse[n] = GFC_ENABLE_REVERSE;
dnovillo's avatar
 
dnovillo committed
6170
      /* Resolve any data dependencies in the statement.  */
6171
      gfc_conv_resolve_dependencies (&loop, lss, rss);
dnovillo's avatar
 
dnovillo committed
6172
      /* Setup the scalarizing loops.  */
6173
      gfc_conv_loop_setup (&loop, &expr2->where);
dnovillo's avatar
 
dnovillo committed
6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192

      /* 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);
	}

jakub's avatar
jakub committed
6193 6194 6195 6196
      /* Allow the scalarizer to workshare array assignments.  */
      if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
	ompws_flags |= OMPWS_SCALARIZER_WS;

dnovillo's avatar
 
dnovillo committed
6197 6198 6199 6200 6201 6202
      /* Start the scalarized loop body.  */
      gfc_start_scalarized_body (&loop, &body);
    }
  else
    gfc_init_block (&body);

6203 6204
  l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);

dnovillo's avatar
 
dnovillo committed
6205 6206 6207
  /* Translate the expression.  */
  gfc_conv_expr (&rse, expr2);

6208 6209 6210 6211 6212 6213
  /* 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;

6214
  if (l_is_temp)
dnovillo's avatar
 
dnovillo committed
6215 6216
    {
      gfc_conv_tmp_array_ref (&lse);
6217 6218
      if (expr2->ts.type == BT_CHARACTER)
	lse.string_length = string_length;
dnovillo's avatar
 
dnovillo committed
6219 6220 6221
    }
  else
    gfc_conv_expr (&lse, expr1);
kazu's avatar
kazu committed
6222

6223 6224 6225 6226
  /* 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
6227
		       && expr2->ts.u.derived->attr.alloc_comp
6228
		       && !expr_is_variable (expr2)
6229 6230
		       && !gfc_is_constant_expr (expr2)
		       && expr1->rank && !expr2->rank);
6231
  if (scalar_to_array && dealloc)
6232
    {
6233
      tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6234 6235 6236
      gfc_add_expr_to_block (&loop.post, tmp);
    }

6237 6238 6239
  /* For a deferred character length function, the function call must
     happen before the (re)allocation of the lhs, otherwise the character
     length of the result is not known.  */
6240 6241 6242 6243
  def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
			   || (expr2->expr_type == EXPR_COMPCALL)
			   || (expr2->expr_type == EXPR_PPC))
		       && expr2->ts.deferred);
6244 6245
  if (gfc_option.flag_realloc_lhs
	&& expr2->ts.type == BT_CHARACTER
6246 6247
	&& (def_clen_func || expr2->expr_type == EXPR_OP)
	&& expr1->ts.deferred)
6248 6249
    gfc_add_block_to_block (&block, &rse.pre);

6250 6251
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
				 l_is_temp || init_flag,
burnus's avatar
burnus committed
6252 6253
				 expr_is_variable (expr2) || scalar_to_array
				 || expr2->expr_type == EXPR_ARRAY, dealloc);
dnovillo's avatar
 
dnovillo committed
6254 6255 6256 6257
  gfc_add_expr_to_block (&body, tmp);

  if (lss == gfc_ss_terminator)
    {
6258 6259 6260 6261 6262 6263
      /* F2003: Add the code for reallocation on assignment.  */
      if (gfc_option.flag_realloc_lhs
	    && is_scalar_reallocatable_lhs (expr1))
	alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
						 expr1, expr2);

dnovillo's avatar
 
dnovillo committed
6264 6265 6266 6267 6268
      /* Use the scalar assignment as is.  */
      gfc_add_block_to_block (&block, &body);
    }
  else
    {
pbrook's avatar
pbrook committed
6269 6270
      gcc_assert (lse.ss == gfc_ss_terminator
		  && rse.ss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
6271

6272
      if (l_is_temp)
dnovillo's avatar
 
dnovillo committed
6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287
	{
	  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
6288 6289
	  gcc_assert (lse.ss == gfc_ss_terminator
		      && rse.ss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
6290

6291 6292 6293
	  if (expr2->ts.type == BT_CHARACTER)
	    rse.string_length = string_length;

6294
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6295
					 false, false, dealloc);
dnovillo's avatar
 
dnovillo committed
6296 6297
	  gfc_add_expr_to_block (&body, tmp);
	}
6298

6299
      /* F2003: Allocate or reallocate lhs of allocatable array.  */
6300 6301 6302 6303 6304
      if (gfc_option.flag_realloc_lhs
	    && gfc_is_reallocatable_lhs (expr1)
	    && !gfc_expr_attr (expr1).codimension
	    && !gfc_is_coindexed (expr1))
	{
jakub's avatar
jakub committed
6305
	  ompws_flags &= ~OMPWS_SCALARIZER_WS;
6306 6307 6308 6309 6310
	  tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
	  if (tmp != NULL_TREE)
	    gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
	}

dnovillo's avatar
 
dnovillo committed
6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323
      /* 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
6324

6325
/* Check whether EXPR is a copyable array.  */
sayle's avatar
 
sayle committed
6326 6327 6328 6329

static bool
copyable_array_p (gfc_expr * expr)
{
6330 6331 6332
  if (expr->expr_type != EXPR_VARIABLE)
    return false;

sayle's avatar
 
sayle committed
6333
  /* First check it's an array.  */
6334 6335 6336
  if (expr->rank < 1 || !expr->ref || expr->ref->next)
    return false;

6337
  if (!gfc_full_array_ref_p (expr->ref, NULL))
sayle's avatar
 
sayle committed
6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348
    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
6349 6350 6351 6352
    case BT_CHARACTER:
      return false;

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

sayle's avatar
 
sayle committed
6355 6356 6357 6358 6359 6360 6361 6362 6363 6364
    default:
      break;
    }

  return false;
}

/* Translate an assignment.  */

tree
6365 6366
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
		      bool dealloc)
sayle's avatar
 
sayle committed
6367 6368
{
  tree tmp;
6369

sayle's avatar
 
sayle committed
6370 6371 6372 6373 6374 6375 6376 6377 6378
  /* 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.  */
6379
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
6380 6381 6382 6383 6384 6385 6386 6387
      && is_zero_initializer_p (expr2))
    {
      tmp = gfc_trans_zero_assign (expr1);
      if (tmp)
        return tmp;
    }

  /* Special case copying one array to another.  */
6388
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
6389 6390 6391 6392 6393 6394 6395 6396 6397
      && 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
6398
  /* Special case initializing an array from a constant array constructor.  */
6399
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
6400 6401 6402 6403 6404 6405 6406 6407
      && 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
6408
  /* Fallback to the scalarizer to generate explicit loops.  */
6409
  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
sayle's avatar
 
sayle committed
6410 6411
}

6412 6413 6414
tree
gfc_trans_init_assign (gfc_code * code)
{
6415
  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6416 6417
}

dnovillo's avatar
 
dnovillo committed
6418 6419 6420
tree
gfc_trans_assign (gfc_code * code)
{
6421
  return gfc_trans_assignment (code->expr1, code->expr2, false, true);
dnovillo's avatar
 
dnovillo committed
6422
}
6423 6424


6425 6426 6427
/* 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.  */
6428 6429 6430 6431 6432

tree
gfc_trans_class_init_assign (gfc_code *code)
{
  stmtblock_t block;
6433 6434 6435 6436
  tree tmp;
  gfc_se dst,src,memsz;
  gfc_expr *lhs,*rhs,*sz;

6437
  gfc_start_block (&block);
6438 6439

  lhs = gfc_copy_expr (code->expr1);
6440
  gfc_add_data_component (lhs);
6441 6442

  rhs = gfc_copy_expr (code->expr1);
6443
  gfc_add_vptr_component (rhs);
6444 6445 6446 6447 6448

  /* Make sure that the component backend_decls have been built, which
     will not have happened if the derived types concerned have not
     been referenced.  */
  gfc_get_derived_type (rhs->ts.u.derived);
6449
  gfc_add_def_init_component (rhs);
6450 6451

  sz = gfc_copy_expr (code->expr1);
6452 6453
  gfc_add_vptr_component (sz);
  gfc_add_size_component (sz);
6454

6455 6456
  gfc_init_se (&dst, NULL);
  gfc_init_se (&src, NULL);
6457 6458 6459 6460
  gfc_init_se (&memsz, NULL);
  gfc_conv_expr (&dst, lhs);
  gfc_conv_expr (&src, rhs);
  gfc_conv_expr (&memsz, sz);
6461
  gfc_add_block_to_block (&block, &src.pre);
6462
  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6463 6464 6465 6466 6467 6468
  gfc_add_expr_to_block (&block, tmp);
  
  return gfc_finish_block (&block);
}


6469 6470 6471 6472
/* Translate an assignment to a CLASS object
   (pointer or ordinary assignment).  */

tree
6473
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6474 6475 6476
{
  stmtblock_t block;
  tree tmp;
janus's avatar
janus committed
6477 6478
  gfc_expr *lhs;
  gfc_expr *rhs;
6479 6480 6481

  gfc_start_block (&block);

6482
  if (expr2->ts.type != BT_CLASS)
6483
    {
6484
      /* Insert an additional assignment which sets the '_vptr' field.  */
6485
      gfc_symbol *vtab = NULL;
6486 6487
      gfc_symtree *st;

6488
      lhs = gfc_copy_expr (expr1);
6489
      gfc_add_vptr_component (lhs);
6490

6491
      if (expr2->ts.type == BT_DERIVED)
6492
	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6493
      else if (expr2->expr_type == EXPR_NULL)
6494 6495 6496 6497 6498 6499 6500 6501
	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
      gcc_assert (vtab);

      rhs = gfc_get_expr ();
      rhs->expr_type = EXPR_VARIABLE;
      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
      rhs->symtree = st;
      rhs->ts = vtab->ts;
6502

janus's avatar
janus committed
6503 6504 6505
      tmp = gfc_trans_pointer_assignment (lhs, rhs);
      gfc_add_expr_to_block (&block, tmp);

6506 6507 6508 6509 6510
      gfc_free_expr (lhs);
      gfc_free_expr (rhs);
    }

  /* Do the actual CLASS assignment.  */
6511 6512
  if (expr2->ts.type == BT_CLASS)
    op = EXEC_ASSIGN;
6513
  else
6514
    gfc_add_data_component (expr1);
6515

6516 6517 6518 6519
  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);
6520 6521 6522 6523 6524 6525 6526
  else
    gcc_unreachable();

  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}