gcc/fortran/expr.c

37      expr.c (gfc_get_variable_expr)
347 	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
494       gfc_internal_error ("free_expr0(): Bad expr type");
528       gfc_free_expr (a1->expr);
549       new_arg->expr = gfc_copy_expr (p->expr);
619 gfc_extract_int (gfc_expr *expr, int *result)
621   if (expr->expr_type != EXPR_CONSTANT)
624   if (expr->ts.type != BT_INTEGER)
627   if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
628       || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
633   *result = (int) mpz_get_si (expr->value.integer);
801   p->value.function.actual->expr = e;
919 	    if (!gfc_is_constant_expr (arg->expr))
966 	if (!gfc_is_constant_expr (c->expr))
1160       if (c->expr)
1165 	  p = gfc_copy_expr (c->expr);
1173 	  gfc_replace_expr (c->expr, p);
1285       c = gfc_constructor_first (c->expr->value.constructor);
1310       e = cons->expr;
1311       cons->expr = NULL;
1324 find_array_section (gfc_expr *expr, gfc_ref *ref)
1353   base = expr->value.constructor;
1354   expr->value.constructor = NULL;
1358   if (expr->shape == NULL)
1359     expr->shape = gfc_get_shape (rank);
1408 	  mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1410 	  mpz_set (expr->shape[shape_i++], begin->shape[0]);
1415 	      if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1416 		  || mpz_cmp (ci->expr->value.integer,
1486 	    mpz_set (expr->shape[shape_i++], tmp_mpz);
1528 	      mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1549 		     "option", &expr->where, flag_max_array_constructor);
1555       gfc_constructor_append_expr (&expr->value.constructor,
1556 				   gfc_copy_expr (cons->expr), NULL);
1657 		      c->expr->ref = gfc_copy_ref (p->ref->next);
1658 		      if (!simplify_const_ref (c->expr))
1667 		      p->ts = c->expr->ts;
1683 			  const gfc_expr* first = c->expr;
1833 	if (!gfc_simplify_expr (ap->expr, type))
1959   gfc_expr *expr, *old;
1970       if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
1973       expr = gfc_copy_expr (a->expr);
1982   gfc_constructor_free (expr->value.constructor);
1983   expr->value.constructor = NULL;
1984   expr->ts = old->ts;
1985   expr->where = old->where;
1986   expr->expr_type = EXPR_ARRAY;
1995       if (a->expr && !gfc_check_init_expr (a->expr))
1999       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2001 	  rank[n] = a->expr->rank;
2002 	  ctor = a->expr->symtree->n.sym->value->value.constructor;
2005       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2007 	  if (a->expr->rank)
2008 	    rank[n] = a->expr->rank;
2011 	  ctor = gfc_constructor_copy (a->expr->value.constructor);
2026       new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2029       gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2035 	    new_ctor->expr->value.function.actual
2044 	    a->expr = gfc_copy_expr (args[i]->expr);
2046 	    a->expr = gfc_copy_expr (b->expr);
2054       gfc_simplify_expr (new_ctor->expr, 0);
2067   *e = *expr;
2068   /* Free "expr" but not the pointers it contains.  */
2069   free (expr);
2077   gfc_free_expr (expr);
2215       if (comp->attr.allocatable && ctor->expr
2216           && ctor->expr->expr_type != EXPR_NULL)
2220 		     comp->name, &ctor->expr->where);
2234     if (!gfc_check_init_expr (ap->expr))
2310       if (!ap->expr)
2313       if (ap->expr->ts.type == BT_UNKNOWN)
2315 	  if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2316 	      && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
2319 	  ap->expr->ts = ap->expr->symtree->n.sym->ts;
2325 	    && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2326 	    && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
2327 		|| ap->expr->symtree->n.sym->ts.deferred))
2331 			ap->expr->symtree->n.sym->name,
2332 			&ap->expr->where);
2335 	else if (not_restricted && !gfc_check_init_expr (ap->expr))
2339 	      && ap->expr->expr_type != EXPR_VARIABLE
2340 	      && !check_restricted (ap->expr))
2344 	    && ap->expr->expr_type == EXPR_VARIABLE
2345 	    && ap->expr->symtree->n.sym->attr.dummy
2346 	    && ap->expr->symtree->n.sym->attr.optional)
2662 gfc_reduce_init_expr (gfc_expr *expr)
2667   t = gfc_resolve_expr (expr);
2669     t = gfc_check_init_expr (expr);
2675   if (expr->expr_type == EXPR_ARRAY)
2677       if (!gfc_check_constructor_type (expr))
2679       if (!gfc_expand_constructor (expr, true))
2693   gfc_expr *expr;
2697   expr = NULL;
2701   m = gfc_match_expr (&expr);
2708   t = gfc_reduce_init_expr (expr);
2711       gfc_free_expr (expr);
2716   *result = expr;
2732       if (!check_restricted (a->expr))
2804     if (!checker (arg->expr))
3992 	  ctor->expr = gfc_copy_expr (comp->initializer);
3996 	    gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
4002 	  ctor->expr = gfc_get_expr ();
4003 	  ctor->expr->expr_type = EXPR_NULL;
4004 	  ctor->expr->ts = comp->ts;
4096 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
4101   if (expr->rank == 0)
4105   if (expr->expr_type == EXPR_VARIABLE
4106       || expr->expr_type == EXPR_CONSTANT)
4108       as = expr->symtree->n.sym->as;
4109       for (ref = expr->ref; ref; ref = ref->next)
4148 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
4158   if (!expr)
4161   if ((*func) (expr, sym, &f))
4164   if (expr->ts.type == BT_CHARACTER
4165 	&& expr->ts.u.cl
4166 	&& expr->ts.u.cl->length
4167 	&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
4168 	&& gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
4171   switch (expr->expr_type)
4176       for (args = expr->value.function.actual; args; args = args->next)
4178 	  if (gfc_traverse_expr (args->expr, sym, func, f))
4191       for (c = gfc_constructor_first (expr->value.constructor);
4194 	  if (gfc_traverse_expr (c->expr, sym, func, f))
4211       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
4213       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
4222   ref = expr->ref;
4278 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
4281 expr_set_symbols_referenced (gfc_expr *expr,
4285   if (expr->expr_type != EXPR_VARIABLE)
4287   gfc_set_sym_referenced (expr->symtree->n.sym);
4292 gfc_expr_set_symbols_referenced (gfc_expr *expr)
4294   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
4302 gfc_get_proc_ptr_comp (gfc_expr *expr)
4306   if (!expr || !expr->ref)
4309   ref = expr->ref;
4324 gfc_is_proc_ptr_comp (gfc_expr *expr)
4326   return (gfc_get_proc_ptr_comp (expr) != NULL);
4333 gfc_is_alloc_class_scalar_function (gfc_expr *expr)
4335   if (expr->expr_type == EXPR_FUNCTION
4336       && expr->value.function.esym
4337       && expr->value.function.esym->result
4338       && expr->value.function.esym->result->ts.type == BT_CLASS
4339       && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4340       && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
4350 gfc_is_alloc_class_array_function (gfc_expr *expr)
4352   if (expr->expr_type == EXPR_FUNCTION
4353       && expr->value.function.esym
4354       && expr->value.function.esym->result
4355       && expr->value.function.esym->result->ts.type == BT_CLASS
4356       && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4357       && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
4617 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4625   if (expr->expr_type == EXPR_FUNCTION)
4626     return expr->value.function.esym
4627 	   ? expr->value.function.esym->result->attr.contiguous : false;
4628   else if (expr->expr_type != EXPR_VARIABLE)
4631   if (expr->rank == 0)
4634   for (ref = expr->ref; ref; ref = ref->next)
4647   sym = expr->symtree->n.sym;
4648   if (expr->ts.type != BT_CLASS
4766       atail->expr = va_arg (ap, gfc_expr*);
4843   /* Find out whether the expr is a pointer; this also means following
5049 		      ec = c->expr;
5057 			  en = n->expr;