1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e = gfc_getmem (sizeof (gfc_expr));
37 gfc_clear_ts (&e->ts);
41 e->con_by_offset = NULL;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist *a1)
51 gfc_actual_arglist *a2;
56 gfc_free_expr (a1->expr);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist *p)
68 gfc_actual_arglist *head, *tail, *new;
72 for (; p; p = p->next)
74 new = gfc_get_actual_arglist ();
77 new->expr = gfc_copy_expr (p->expr);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref *p)
107 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
109 gfc_free_expr (p->u.ar.start[i]);
110 gfc_free_expr (p->u.ar.end[i]);
111 gfc_free_expr (p->u.ar.stride[i]);
117 gfc_free_expr (p->u.ss.start);
118 gfc_free_expr (p->u.ss.end);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr *e)
140 switch (e->expr_type)
145 gfc_free (e->value.character.string);
152 mpz_clear (e->value.integer);
156 mpfr_clear (e->value.real);
161 gfc_free (e->value.character.string);
165 mpfr_clear (e->value.complex.r);
166 mpfr_clear (e->value.complex.i);
176 if (e->value.op.op1 != NULL)
177 gfc_free_expr (e->value.op.op1);
178 if (e->value.op.op2 != NULL)
179 gfc_free_expr (e->value.op.op2);
183 gfc_free_actual_arglist (e->value.function.actual);
191 gfc_free_constructor (e->value.constructor);
195 gfc_free (e->value.character.string);
202 gfc_internal_error ("free_expr0(): Bad expr type");
205 /* Free a shape array. */
206 if (e->shape != NULL)
208 for (n = 0; n < e->rank; n++)
209 mpz_clear (e->shape[n]);
214 gfc_free_ref_list (e->ref);
216 memset (e, '\0', sizeof (gfc_expr));
220 /* Free an expression node and everything beneath it. */
223 gfc_free_expr (gfc_expr *e)
227 if (e->con_by_offset)
228 splay_tree_delete (e->con_by_offset);
234 /* Graft the *src expression onto the *dest subexpression. */
237 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
245 /* Try to extract an integer constant from the passed expression node.
246 Returns an error message or NULL if the result is set. It is
247 tempting to generate an error and return SUCCESS or FAILURE, but
248 failure is OK for some callers. */
251 gfc_extract_int (gfc_expr *expr, int *result)
253 if (expr->expr_type != EXPR_CONSTANT)
254 return _("Constant expression required at %C");
256 if (expr->ts.type != BT_INTEGER)
257 return _("Integer expression required at %C");
259 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
260 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
262 return _("Integer value too large in expression at %C");
265 *result = (int) mpz_get_si (expr->value.integer);
271 /* Recursively copy a list of reference structures. */
274 copy_ref (gfc_ref *src)
282 dest = gfc_get_ref ();
283 dest->type = src->type;
288 ar = gfc_copy_array_ref (&src->u.ar);
294 dest->u.c = src->u.c;
298 dest->u.ss = src->u.ss;
299 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
300 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
304 dest->next = copy_ref (src->next);
310 /* Detect whether an expression has any vector index array references. */
313 gfc_has_vector_index (gfc_expr *e)
317 for (ref = e->ref; ref; ref = ref->next)
318 if (ref->type == REF_ARRAY)
319 for (i = 0; i < ref->u.ar.dimen; i++)
320 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
326 /* Copy a shape array. */
329 gfc_copy_shape (mpz_t *shape, int rank)
337 new_shape = gfc_get_shape (rank);
339 for (n = 0; n < rank; n++)
340 mpz_init_set (new_shape[n], shape[n]);
346 /* Copy a shape array excluding dimension N, where N is an integer
347 constant expression. Dimensions are numbered in fortran style --
350 So, if the original shape array contains R elements
351 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
352 the result contains R-1 elements:
353 { s1 ... sN-1 sN+1 ... sR-1}
355 If anything goes wrong -- N is not a constant, its value is out
356 of range -- or anything else, just returns NULL.
360 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
362 mpz_t *new_shape, *s;
368 || dim->expr_type != EXPR_CONSTANT
369 || dim->ts.type != BT_INTEGER)
372 n = mpz_get_si (dim->value.integer);
373 n--; /* Convert to zero based index */
374 if (n < 0 || n >= rank)
377 s = new_shape = gfc_get_shape (rank - 1);
379 for (i = 0; i < rank; i++)
383 mpz_init_set (*s, shape[i]);
391 /* Given an expression pointer, return a copy of the expression. This
392 subroutine is recursive. */
395 gfc_copy_expr (gfc_expr *p)
406 switch (q->expr_type)
409 s = gfc_getmem (p->value.character.length + 1);
410 q->value.character.string = s;
412 memcpy (s, p->value.character.string, p->value.character.length + 1);
418 s = gfc_getmem (p->value.character.length + 1);
419 q->value.character.string = s;
421 memcpy (s, p->value.character.string, p->value.character.length + 1);
427 mpz_init_set (q->value.integer, p->value.integer);
431 gfc_set_model_kind (q->ts.kind);
432 mpfr_init (q->value.real);
433 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
437 gfc_set_model_kind (q->ts.kind);
438 mpfr_init (q->value.complex.r);
439 mpfr_init (q->value.complex.i);
440 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
441 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
446 s = gfc_getmem (p->value.character.length + 1);
447 q->value.character.string = s;
449 memcpy (s, p->value.character.string, p->value.character.length + 1);
454 break; /* Already done */
458 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
465 switch (q->value.op.operator)
468 case INTRINSIC_UPLUS:
469 case INTRINSIC_UMINUS:
470 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
473 default: /* Binary operators */
474 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
475 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
482 q->value.function.actual =
483 gfc_copy_actual_arglist (p->value.function.actual);
488 q->value.constructor = gfc_copy_constructor (p->value.constructor);
496 q->shape = gfc_copy_shape (p->shape, p->rank);
498 q->ref = copy_ref (p->ref);
504 /* Return the maximum kind of two expressions. In general, higher
505 kind numbers mean more precision for numeric types. */
508 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
510 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
514 /* Returns nonzero if the type is numeric, zero otherwise. */
517 numeric_type (bt type)
519 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
523 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
526 gfc_numeric_ts (gfc_typespec *ts)
528 return numeric_type (ts->type);
532 /* Returns an expression node that is an integer constant. */
541 p->expr_type = EXPR_CONSTANT;
542 p->ts.type = BT_INTEGER;
543 p->ts.kind = gfc_default_integer_kind;
545 p->where = gfc_current_locus;
546 mpz_init_set_si (p->value.integer, i);
552 /* Returns an expression node that is a logical constant. */
555 gfc_logical_expr (int i, locus *where)
561 p->expr_type = EXPR_CONSTANT;
562 p->ts.type = BT_LOGICAL;
563 p->ts.kind = gfc_default_logical_kind;
566 where = &gfc_current_locus;
568 p->value.logical = i;
574 /* Return an expression node with an optional argument list attached.
575 A variable number of gfc_expr pointers are strung together in an
576 argument list with a NULL pointer terminating the list. */
579 gfc_build_conversion (gfc_expr *e)
584 p->expr_type = EXPR_FUNCTION;
586 p->value.function.actual = NULL;
588 p->value.function.actual = gfc_get_actual_arglist ();
589 p->value.function.actual->expr = e;
595 /* Given an expression node with some sort of numeric binary
596 expression, insert type conversions required to make the operands
599 The exception is that the operands of an exponential don't have to
600 have the same type. If possible, the base is promoted to the type
601 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
602 1.0**2 stays as it is. */
605 gfc_type_convert_binary (gfc_expr *e)
609 op1 = e->value.op.op1;
610 op2 = e->value.op.op2;
612 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
614 gfc_clear_ts (&e->ts);
618 /* Kind conversions of same type. */
619 if (op1->ts.type == op2->ts.type)
621 if (op1->ts.kind == op2->ts.kind)
623 /* No type conversions. */
628 if (op1->ts.kind > op2->ts.kind)
629 gfc_convert_type (op2, &op1->ts, 2);
631 gfc_convert_type (op1, &op2->ts, 2);
637 /* Integer combined with real or complex. */
638 if (op2->ts.type == BT_INTEGER)
642 /* Special case for ** operator. */
643 if (e->value.op.operator == INTRINSIC_POWER)
646 gfc_convert_type (e->value.op.op2, &e->ts, 2);
650 if (op1->ts.type == BT_INTEGER)
653 gfc_convert_type (e->value.op.op1, &e->ts, 2);
657 /* Real combined with complex. */
658 e->ts.type = BT_COMPLEX;
659 if (op1->ts.kind > op2->ts.kind)
660 e->ts.kind = op1->ts.kind;
662 e->ts.kind = op2->ts.kind;
663 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
664 gfc_convert_type (e->value.op.op1, &e->ts, 2);
665 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
666 gfc_convert_type (e->value.op.op2, &e->ts, 2);
673 /* Function to determine if an expression is constant or not. This
674 function expects that the expression has already been simplified. */
677 gfc_is_constant_expr (gfc_expr *e)
680 gfc_actual_arglist *arg;
686 switch (e->expr_type)
689 rv = (gfc_is_constant_expr (e->value.op.op1)
690 && (e->value.op.op2 == NULL
691 || gfc_is_constant_expr (e->value.op.op2)));
700 /* Call to intrinsic with at least one argument. */
702 if (e->value.function.isym && e->value.function.actual)
704 for (arg = e->value.function.actual; arg; arg = arg->next)
706 if (!gfc_is_constant_expr (arg->expr))
720 rv = (gfc_is_constant_expr (e->ref->u.ss.start)
721 && gfc_is_constant_expr (e->ref->u.ss.end));
726 for (c = e->value.constructor; c; c = c->next)
727 if (!gfc_is_constant_expr (c->expr))
735 rv = gfc_constant_ac (e);
739 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
746 /* Try to collapse intrinsic expressions. */
749 simplify_intrinsic_op (gfc_expr *p, int type)
751 gfc_expr *op1, *op2, *result;
753 if (p->value.op.operator == INTRINSIC_USER)
756 op1 = p->value.op.op1;
757 op2 = p->value.op.op2;
759 if (gfc_simplify_expr (op1, type) == FAILURE)
761 if (gfc_simplify_expr (op2, type) == FAILURE)
764 if (!gfc_is_constant_expr (op1)
765 || (op2 != NULL && !gfc_is_constant_expr (op2)))
769 p->value.op.op1 = NULL;
770 p->value.op.op2 = NULL;
772 switch (p->value.op.operator)
774 case INTRINSIC_UPLUS:
775 case INTRINSIC_PARENTHESES:
776 result = gfc_uplus (op1);
779 case INTRINSIC_UMINUS:
780 result = gfc_uminus (op1);
784 result = gfc_add (op1, op2);
787 case INTRINSIC_MINUS:
788 result = gfc_subtract (op1, op2);
791 case INTRINSIC_TIMES:
792 result = gfc_multiply (op1, op2);
795 case INTRINSIC_DIVIDE:
796 result = gfc_divide (op1, op2);
799 case INTRINSIC_POWER:
800 result = gfc_power (op1, op2);
803 case INTRINSIC_CONCAT:
804 result = gfc_concat (op1, op2);
808 result = gfc_eq (op1, op2);
812 result = gfc_ne (op1, op2);
816 result = gfc_gt (op1, op2);
820 result = gfc_ge (op1, op2);
824 result = gfc_lt (op1, op2);
828 result = gfc_le (op1, op2);
832 result = gfc_not (op1);
836 result = gfc_and (op1, op2);
840 result = gfc_or (op1, op2);
844 result = gfc_eqv (op1, op2);
848 result = gfc_neqv (op1, op2);
852 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
862 result->rank = p->rank;
863 result->where = p->where;
864 gfc_replace_expr (p, result);
870 /* Subroutine to simplify constructor expressions. Mutually recursive
871 with gfc_simplify_expr(). */
874 simplify_constructor (gfc_constructor *c, int type)
876 for (; c; c = c->next)
879 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
880 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
881 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
884 if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
892 /* Pull a single array element out of an array constructor. */
895 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
896 gfc_constructor **rval)
898 unsigned long nelemen;
908 mpz_init_set_ui (offset, 0);
910 for (i = 0; i < ar->dimen; i++)
912 e = gfc_copy_expr (ar->start[i]);
913 if (e->expr_type != EXPR_CONSTANT)
919 /* Check the bounds. */
921 && (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
922 || mpz_cmp (e->value.integer,
923 ar->as->lower[i]->value.integer) < 0))
925 gfc_error ("index in dimension %d is out of bounds "
926 "at %L", i + 1, &ar->c_where[i]);
932 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
933 mpz_add (offset, offset, delta);
938 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
959 /* Find a component of a structure constructor. */
961 static gfc_constructor *
962 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
967 comp = ref->u.c.sym->components;
968 pick = ref->u.c.component;
979 /* Replace an expression with the contents of a constructor, removing
980 the subobject reference in the process. */
983 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
989 e->ref = p->ref->next;
991 gfc_replace_expr (p, e);
995 /* Pull an array section out of an array constructor. */
998 find_array_section (gfc_expr *expr, gfc_ref *ref)
1004 long unsigned one = 1;
1006 mpz_t start[GFC_MAX_DIMENSIONS];
1007 mpz_t end[GFC_MAX_DIMENSIONS];
1008 mpz_t stride[GFC_MAX_DIMENSIONS];
1009 mpz_t delta[GFC_MAX_DIMENSIONS];
1010 mpz_t ctr[GFC_MAX_DIMENSIONS];
1016 gfc_constructor *cons;
1017 gfc_constructor *base;
1023 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1028 base = expr->value.constructor;
1029 expr->value.constructor = NULL;
1031 rank = ref->u.ar.as->rank;
1033 if (expr->shape == NULL)
1034 expr->shape = gfc_get_shape (rank);
1036 mpz_init_set_ui (delta_mpz, one);
1037 mpz_init_set_ui (nelts, one);
1040 /* Do the initialization now, so that we can cleanup without
1041 keeping track of where we were. */
1042 for (d = 0; d < rank; d++)
1044 mpz_init (delta[d]);
1045 mpz_init (start[d]);
1048 mpz_init (stride[d]);
1052 /* Build the counters to clock through the array reference. */
1054 for (d = 0; d < rank; d++)
1056 /* Make this stretch of code easier on the eye! */
1057 begin = ref->u.ar.start[d];
1058 finish = ref->u.ar.end[d];
1059 step = ref->u.ar.stride[d];
1060 lower = ref->u.ar.as->lower[d];
1061 upper = ref->u.ar.as->upper[d];
1063 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1066 gcc_assert (begin->expr_type == EXPR_ARRAY);
1067 gcc_assert (begin->rank == 1);
1068 gcc_assert (begin->shape);
1070 vecsub[d] = begin->value.constructor;
1071 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1072 mpz_mul (nelts, nelts, begin->shape[0]);
1073 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1076 for (c = vecsub[d]; c; c = c->next)
1078 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1079 || mpz_cmp (c->expr->value.integer,
1080 lower->value.integer) < 0)
1082 gfc_error ("index in dimension %d is out of bounds "
1083 "at %L", d + 1, &ref->u.ar.c_where[d]);
1091 if ((begin && begin->expr_type != EXPR_CONSTANT)
1092 || (finish && finish->expr_type != EXPR_CONSTANT)
1093 || (step && step->expr_type != EXPR_CONSTANT))
1099 /* Obtain the stride. */
1101 mpz_set (stride[d], step->value.integer);
1103 mpz_set_ui (stride[d], one);
1105 if (mpz_cmp_ui (stride[d], 0) == 0)
1106 mpz_set_ui (stride[d], one);
1108 /* Obtain the start value for the index. */
1110 mpz_set (start[d], begin->value.integer);
1112 mpz_set (start[d], lower->value.integer);
1114 mpz_set (ctr[d], start[d]);
1116 /* Obtain the end value for the index. */
1118 mpz_set (end[d], finish->value.integer);
1120 mpz_set (end[d], upper->value.integer);
1122 /* Separate 'if' because elements sometimes arrive with
1124 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1125 mpz_set (end [d], begin->value.integer);
1127 /* Check the bounds. */
1128 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1129 || mpz_cmp (end[d], upper->value.integer) > 0
1130 || mpz_cmp (ctr[d], lower->value.integer) < 0
1131 || mpz_cmp (end[d], lower->value.integer) < 0)
1133 gfc_error ("index in dimension %d is out of bounds "
1134 "at %L", d + 1, &ref->u.ar.c_where[d]);
1139 /* Calculate the number of elements and the shape. */
1140 mpz_abs (tmp_mpz, stride[d]);
1141 mpz_div (tmp_mpz, stride[d], tmp_mpz);
1142 mpz_add (tmp_mpz, end[d], tmp_mpz);
1143 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1144 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1145 mpz_mul (nelts, nelts, tmp_mpz);
1147 /* An element reference reduces the rank of the expression; don't
1148 add anything to the shape array. */
1149 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1150 mpz_set (expr->shape[shape_i++], tmp_mpz);
1153 /* Calculate the 'stride' (=delta) for conversion of the
1154 counter values into the index along the constructor. */
1155 mpz_set (delta[d], delta_mpz);
1156 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1157 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1158 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1165 /* Now clock through the array reference, calculating the index in
1166 the source constructor and transferring the elements to the new
1168 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1170 if (ref->u.ar.offset)
1171 mpz_set (ptr, ref->u.ar.offset->value.integer);
1173 mpz_init_set_ui (ptr, 0);
1176 for (d = 0; d < rank; d++)
1178 mpz_set (tmp_mpz, ctr[d]);
1179 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1180 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1181 mpz_add (ptr, ptr, tmp_mpz);
1183 if (!incr_ctr) continue;
1185 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1187 gcc_assert(vecsub[d]);
1189 if (!vecsub[d]->next)
1190 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1193 vecsub[d] = vecsub[d]->next;
1196 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1200 mpz_add (ctr[d], ctr[d], stride[d]);
1202 if (mpz_cmp_ui (stride[d], 0) > 0
1203 ? mpz_cmp (ctr[d], end[d]) > 0
1204 : mpz_cmp (ctr[d], end[d]) < 0)
1205 mpz_set (ctr[d], start[d]);
1211 /* There must be a better way of dealing with negative strides
1212 than resetting the index and the constructor pointer! */
1213 if (mpz_cmp (ptr, index) < 0)
1215 mpz_set_ui (index, 0);
1219 while (mpz_cmp (ptr, index) > 0)
1221 mpz_add_ui (index, index, one);
1225 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1233 mpz_clear (delta_mpz);
1234 mpz_clear (tmp_mpz);
1236 for (d = 0; d < rank; d++)
1238 mpz_clear (delta[d]);
1239 mpz_clear (start[d]);
1242 mpz_clear (stride[d]);
1244 gfc_free_constructor (base);
1248 /* Pull a substring out of an expression. */
1251 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1257 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1258 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1261 *newp = gfc_copy_expr (p);
1262 chr = p->value.character.string;
1263 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1264 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1266 (*newp)->value.character.length = end - start + 1;
1267 strncpy ((*newp)->value.character.string, &chr[start - 1],
1268 (*newp)->value.character.length);
1274 /* Simplify a subobject reference of a constructor. This occurs when
1275 parameter variable values are substituted. */
1278 simplify_const_ref (gfc_expr *p)
1280 gfc_constructor *cons;
1285 switch (p->ref->type)
1288 switch (p->ref->u.ar.type)
1291 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1298 remove_subobject_ref (p, cons);
1302 if (find_array_section (p, p->ref) == FAILURE)
1304 p->ref->u.ar.type = AR_FULL;
1309 if (p->ref->next != NULL
1310 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1312 cons = p->value.constructor;
1313 for (; cons; cons = cons->next)
1315 cons->expr->ref = copy_ref (p->ref->next);
1316 simplify_const_ref (cons->expr);
1319 gfc_free_ref_list (p->ref);
1330 cons = find_component_ref (p->value.constructor, p->ref);
1331 remove_subobject_ref (p, cons);
1335 if (find_substring_ref (p, &newp) == FAILURE)
1338 gfc_replace_expr (p, newp);
1339 gfc_free_ref_list (p->ref);
1349 /* Simplify a chain of references. */
1352 simplify_ref_chain (gfc_ref *ref, int type)
1356 for (; ref; ref = ref->next)
1361 for (n = 0; n < ref->u.ar.dimen; n++)
1363 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1365 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1367 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1373 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1375 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1387 /* Try to substitute the value of a parameter variable. */
1389 simplify_parameter_variable (gfc_expr *p, int type)
1394 e = gfc_copy_expr (p->symtree->n.sym->value);
1400 /* Do not copy subobject refs for constant. */
1401 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1402 e->ref = copy_ref (p->ref);
1403 t = gfc_simplify_expr (e, type);
1405 /* Only use the simplification if it eliminated all subobject
1407 if (t == SUCCESS && !e->ref)
1408 gfc_replace_expr (p, e);
1415 /* Given an expression, simplify it by collapsing constant
1416 expressions. Most simplification takes place when the expression
1417 tree is being constructed. If an intrinsic function is simplified
1418 at some point, we get called again to collapse the result against
1421 We work by recursively simplifying expression nodes, simplifying
1422 intrinsic functions where possible, which can lead to further
1423 constant collapsing. If an operator has constant operand(s), we
1424 rip the expression apart, and rebuild it, hoping that it becomes
1427 The expression type is defined for:
1428 0 Basic expression parsing
1429 1 Simplifying array constructors -- will substitute
1431 Returns FAILURE on error, SUCCESS otherwise.
1432 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1435 gfc_simplify_expr (gfc_expr *p, int type)
1437 gfc_actual_arglist *ap;
1442 switch (p->expr_type)
1449 for (ap = p->value.function.actual; ap; ap = ap->next)
1450 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1453 if (p->value.function.isym != NULL
1454 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1459 case EXPR_SUBSTRING:
1460 if (simplify_ref_chain (p->ref, type) == FAILURE)
1463 if (gfc_is_constant_expr (p))
1468 gfc_extract_int (p->ref->u.ss.start, &start);
1469 start--; /* Convert from one-based to zero-based. */
1470 gfc_extract_int (p->ref->u.ss.end, &end);
1471 s = gfc_getmem (end - start + 2);
1472 memcpy (s, p->value.character.string + start, end - start);
1473 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1474 gfc_free (p->value.character.string);
1475 p->value.character.string = s;
1476 p->value.character.length = end - start;
1477 p->ts.cl = gfc_get_charlen ();
1478 p->ts.cl->next = gfc_current_ns->cl_list;
1479 gfc_current_ns->cl_list = p->ts.cl;
1480 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1481 gfc_free_ref_list (p->ref);
1483 p->expr_type = EXPR_CONSTANT;
1488 if (simplify_intrinsic_op (p, type) == FAILURE)
1493 /* Only substitute array parameter variables if we are in an
1494 initialization expression, or we want a subsection. */
1495 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1496 && (gfc_init_expr || p->ref
1497 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1499 if (simplify_parameter_variable (p, type) == FAILURE)
1506 gfc_simplify_iterator_var (p);
1509 /* Simplify subcomponent references. */
1510 if (simplify_ref_chain (p->ref, type) == FAILURE)
1515 case EXPR_STRUCTURE:
1517 if (simplify_ref_chain (p->ref, type) == FAILURE)
1520 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1523 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1524 && p->ref->u.ar.type == AR_FULL)
1525 gfc_expand_constructor (p);
1527 if (simplify_const_ref (p) == FAILURE)
1537 /* Returns the type of an expression with the exception that iterator
1538 variables are automatically integers no matter what else they may
1544 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1551 /* Check an intrinsic arithmetic operation to see if it is consistent
1552 with some type of expression. */
1554 static try check_init_expr (gfc_expr *);
1557 check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
1559 gfc_expr *op1 = e->value.op.op1;
1560 gfc_expr *op2 = e->value.op.op2;
1562 if ((*check_function) (op1) == FAILURE)
1565 switch (e->value.op.operator)
1567 case INTRINSIC_UPLUS:
1568 case INTRINSIC_UMINUS:
1569 if (!numeric_type (et0 (op1)))
1579 if ((*check_function) (op2) == FAILURE)
1582 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1583 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1585 gfc_error ("Numeric or CHARACTER operands are required in "
1586 "expression at %L", &e->where);
1591 case INTRINSIC_PLUS:
1592 case INTRINSIC_MINUS:
1593 case INTRINSIC_TIMES:
1594 case INTRINSIC_DIVIDE:
1595 case INTRINSIC_POWER:
1596 if ((*check_function) (op2) == FAILURE)
1599 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1602 if (e->value.op.operator == INTRINSIC_POWER
1603 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1605 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1606 "exponent in an initialization "
1607 "expression at %L", &op2->where)
1614 case INTRINSIC_CONCAT:
1615 if ((*check_function) (op2) == FAILURE)
1618 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1620 gfc_error ("Concatenation operator in expression at %L "
1621 "must have two CHARACTER operands", &op1->where);
1625 if (op1->ts.kind != op2->ts.kind)
1627 gfc_error ("Concat operator at %L must concatenate strings of the "
1628 "same kind", &e->where);
1635 if (et0 (op1) != BT_LOGICAL)
1637 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1638 "operand", &op1->where);
1647 case INTRINSIC_NEQV:
1648 if ((*check_function) (op2) == FAILURE)
1651 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1653 gfc_error ("LOGICAL operands are required in expression at %L",
1660 case INTRINSIC_PARENTHESES:
1664 gfc_error ("Only intrinsic operators can be used in expression at %L",
1672 gfc_error ("Numeric operands are required in expression at %L", &e->where);
1679 /* Certain inquiry functions are specifically allowed to have variable
1680 arguments, which is an exception to the normal requirement that an
1681 initialization function have initialization arguments. We head off
1682 this problem here. */
1685 check_inquiry (gfc_expr *e, int not_restricted)
1689 /* FIXME: This should be moved into the intrinsic definitions,
1690 to eliminate this ugly hack. */
1691 static const char * const inquiry_function[] = {
1692 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1693 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1694 "lbound", "ubound", NULL
1699 /* An undeclared parameter will get us here (PR25018). */
1700 if (e->symtree == NULL)
1703 name = e->symtree->n.sym->name;
1705 for (i = 0; inquiry_function[i]; i++)
1706 if (strcmp (inquiry_function[i], name) == 0)
1709 if (inquiry_function[i] == NULL)
1712 e = e->value.function.actual->expr;
1714 if (e == NULL || e->expr_type != EXPR_VARIABLE)
1717 /* At this point we have an inquiry function with a variable argument. The
1718 type of the variable might be undefined, but we need it now, because the
1719 arguments of these functions are allowed to be undefined. */
1721 if (e->ts.type == BT_UNKNOWN)
1723 if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1724 && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1728 e->ts = e->symtree->n.sym->ts;
1731 /* Assumed character length will not reduce to a constant expression
1732 with LEN, as required by the standard. */
1733 if (i == 4 && not_restricted
1734 && e->symtree->n.sym->ts.type == BT_CHARACTER
1735 && e->symtree->n.sym->ts.cl->length == NULL)
1736 gfc_notify_std (GFC_STD_GNU, "assumed character length "
1737 "variable '%s' in constant expression at %L",
1738 e->symtree->n.sym->name, &e->where);
1744 /* Verify that an expression is an initialization expression. A side
1745 effect is that the expression tree is reduced to a single constant
1746 node if all goes well. This would normally happen when the
1747 expression is constructed but function references are assumed to be
1748 intrinsics in the context of initialization expressions. If
1749 FAILURE is returned an error message has been generated. */
1752 check_init_expr (gfc_expr *e)
1754 gfc_actual_arglist *ap;
1761 switch (e->expr_type)
1764 t = check_intrinsic_op (e, check_init_expr);
1766 t = gfc_simplify_expr (e, 0);
1773 if (check_inquiry (e, 1) != SUCCESS)
1776 for (ap = e->value.function.actual; ap; ap = ap->next)
1777 if (check_init_expr (ap->expr) == FAILURE)
1786 m = gfc_intrinsic_func_interface (e, 0);
1789 gfc_error ("Function '%s' in initialization expression at %L "
1790 "must be an intrinsic function",
1791 e->symtree->n.sym->name, &e->where);
1802 if (gfc_check_iter_variable (e) == SUCCESS)
1805 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1807 t = simplify_parameter_variable (e, 0);
1811 if (gfc_in_match_data ())
1814 gfc_error ("Parameter '%s' at %L has not been declared or is "
1815 "a variable, which does not reduce to a constant "
1816 "expression", e->symtree->n.sym->name, &e->where);
1825 case EXPR_SUBSTRING:
1826 t = check_init_expr (e->ref->u.ss.start);
1830 t = check_init_expr (e->ref->u.ss.end);
1832 t = gfc_simplify_expr (e, 0);
1836 case EXPR_STRUCTURE:
1837 t = gfc_check_constructor (e, check_init_expr);
1841 t = gfc_check_constructor (e, check_init_expr);
1845 t = gfc_expand_constructor (e);
1849 t = gfc_check_constructor_type (e);
1853 gfc_internal_error ("check_init_expr(): Unknown expression type");
1860 /* Match an initialization expression. We work by first matching an
1861 expression, then reducing it to a constant. */
1864 gfc_match_init_expr (gfc_expr **result)
1870 m = gfc_match_expr (&expr);
1875 t = gfc_resolve_expr (expr);
1877 t = check_init_expr (expr);
1882 gfc_free_expr (expr);
1886 if (expr->expr_type == EXPR_ARRAY
1887 && (gfc_check_constructor_type (expr) == FAILURE
1888 || gfc_expand_constructor (expr) == FAILURE))
1890 gfc_free_expr (expr);
1894 /* Not all inquiry functions are simplified to constant expressions
1895 so it is necessary to call check_inquiry again. */
1896 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) == FAILURE
1897 && !gfc_in_match_data ())
1899 gfc_error ("Initialization expression didn't reduce %C");
1909 static try check_restricted (gfc_expr *);
1911 /* Given an actual argument list, test to see that each argument is a
1912 restricted expression and optionally if the expression type is
1913 integer or character. */
1916 restricted_args (gfc_actual_arglist *a)
1918 for (; a; a = a->next)
1920 if (check_restricted (a->expr) == FAILURE)
1928 /************* Restricted/specification expressions *************/
1931 /* Make sure a non-intrinsic function is a specification function. */
1934 external_spec_function (gfc_expr *e)
1938 f = e->value.function.esym;
1940 if (f->attr.proc == PROC_ST_FUNCTION)
1942 gfc_error ("Specification function '%s' at %L cannot be a statement "
1943 "function", f->name, &e->where);
1947 if (f->attr.proc == PROC_INTERNAL)
1949 gfc_error ("Specification function '%s' at %L cannot be an internal "
1950 "function", f->name, &e->where);
1954 if (!f->attr.pure && !f->attr.elemental)
1956 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1961 if (f->attr.recursive)
1963 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1964 f->name, &e->where);
1968 return restricted_args (e->value.function.actual);
1972 /* Check to see that a function reference to an intrinsic is a
1973 restricted expression. */
1976 restricted_intrinsic (gfc_expr *e)
1978 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1979 if (check_inquiry (e, 0) == SUCCESS)
1982 return restricted_args (e->value.function.actual);
1986 /* Verify that an expression is a restricted expression. Like its
1987 cousin check_init_expr(), an error message is generated if we
1991 check_restricted (gfc_expr *e)
1999 switch (e->expr_type)
2002 t = check_intrinsic_op (e, check_restricted);
2004 t = gfc_simplify_expr (e, 0);
2009 t = e->value.function.esym ? external_spec_function (e)
2010 : restricted_intrinsic (e);
2015 sym = e->symtree->n.sym;
2018 if (sym->attr.optional)
2020 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2021 sym->name, &e->where);
2025 if (sym->attr.intent == INTENT_OUT)
2027 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2028 sym->name, &e->where);
2032 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2033 processed in resolve.c(resolve_formal_arglist). This is done so
2034 that host associated dummy array indices are accepted (PR23446).
2035 This mechanism also does the same for the specification expressions
2036 of array-valued functions. */
2037 if (sym->attr.in_common
2038 || sym->attr.use_assoc
2040 || sym->ns != gfc_current_ns
2041 || (sym->ns->proc_name != NULL
2042 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2043 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2049 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2050 sym->name, &e->where);
2059 case EXPR_SUBSTRING:
2060 t = gfc_specification_expr (e->ref->u.ss.start);
2064 t = gfc_specification_expr (e->ref->u.ss.end);
2066 t = gfc_simplify_expr (e, 0);
2070 case EXPR_STRUCTURE:
2071 t = gfc_check_constructor (e, check_restricted);
2075 t = gfc_check_constructor (e, check_restricted);
2079 gfc_internal_error ("check_restricted(): Unknown expression type");
2086 /* Check to see that an expression is a specification expression. If
2087 we return FAILURE, an error has been generated. */
2090 gfc_specification_expr (gfc_expr *e)
2095 if (e->ts.type != BT_INTEGER)
2097 gfc_error ("Expression at %L must be of INTEGER type", &e->where);
2103 gfc_error ("Expression at %L must be scalar", &e->where);
2107 if (gfc_simplify_expr (e, 0) == FAILURE)
2110 return check_restricted (e);
2114 /************** Expression conformance checks. *************/
2116 /* Given two expressions, make sure that the arrays are conformable. */
2119 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2121 int op1_flag, op2_flag, d;
2122 mpz_t op1_size, op2_size;
2125 if (op1->rank == 0 || op2->rank == 0)
2128 if (op1->rank != op2->rank)
2130 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
2137 for (d = 0; d < op1->rank; d++)
2139 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2140 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2142 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2144 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2145 _(optype_msgid), &op1->where, d + 1,
2146 (int) mpz_get_si (op1_size),
2147 (int) mpz_get_si (op2_size));
2153 mpz_clear (op1_size);
2155 mpz_clear (op2_size);
2165 /* Given an assignable expression and an arbitrary expression, make
2166 sure that the assignment can take place. */
2169 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2175 sym = lvalue->symtree->n.sym;
2177 /* Check INTENT(IN), unless the object itself is the component or
2178 sub-component of a pointer. */
2179 has_pointer = sym->attr.pointer;
2181 for (ref = lvalue->ref; ref; ref = ref->next)
2182 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2188 if (!has_pointer && sym->attr.intent == INTENT_IN)
2190 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2191 sym->name, &lvalue->where);
2195 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2196 variable local to a function subprogram. Its existence begins when
2197 execution of the function is initiated and ends when execution of the
2198 function is terminated.....
2199 Therefore, the left hand side is no longer a varaiable, when it is: */
2200 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2201 && !sym->attr.external)
2206 /* (i) Use associated; */
2207 if (sym->attr.use_assoc)
2210 /* (ii) The assignment is in the main program; or */
2211 if (gfc_current_ns->proc_name->attr.is_main_program)
2214 /* (iii) A module or internal procedure.... */
2215 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2216 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2217 && gfc_current_ns->parent
2218 && (!(gfc_current_ns->parent->proc_name->attr.function
2219 || gfc_current_ns->parent->proc_name->attr.subroutine)
2220 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2222 /* .... that is not a function.... */
2223 if (!gfc_current_ns->proc_name->attr.function)
2226 /* .... or is not an entry and has a different name. */
2227 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2233 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2238 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2240 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2241 lvalue->rank, rvalue->rank, &lvalue->where);
2245 if (lvalue->ts.type == BT_UNKNOWN)
2247 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2252 if (rvalue->expr_type == EXPR_NULL)
2254 gfc_error ("NULL appears on right-hand side in assignment at %L",
2259 if (sym->attr.cray_pointee
2260 && lvalue->ref != NULL
2261 && lvalue->ref->u.ar.type == AR_FULL
2262 && lvalue->ref->u.ar.as->cp_was_assumed)
2264 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2265 "is illegal", &lvalue->where);
2269 /* This is possibly a typo: x = f() instead of x => f() */
2270 if (gfc_option.warn_surprising
2271 && rvalue->expr_type == EXPR_FUNCTION
2272 && rvalue->symtree->n.sym->attr.pointer)
2273 gfc_warning ("POINTER valued function appears on right-hand side of "
2274 "assignment at %L", &rvalue->where);
2276 /* Check size of array assignments. */
2277 if (lvalue->rank != 0 && rvalue->rank != 0
2278 && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
2281 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2286 /* Numeric can be converted to any other numeric. And Hollerith can be
2287 converted to any other type. */
2288 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2289 || rvalue->ts.type == BT_HOLLERITH)
2292 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2295 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2296 &rvalue->where, gfc_typename (&rvalue->ts),
2297 gfc_typename (&lvalue->ts));
2302 return gfc_convert_type (rvalue, &lvalue->ts, 1);
2306 /* Check that a pointer assignment is OK. We first check lvalue, and
2307 we only check rvalue if it's not an assignment to NULL() or a
2308 NULLIFY statement. */
2311 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
2313 symbol_attribute attr;
2316 int pointer, check_intent_in;
2318 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
2320 gfc_error ("Pointer assignment target is not a POINTER at %L",
2325 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
2326 && lvalue->symtree->n.sym->attr.use_assoc)
2328 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2329 "l-value since it is a procedure",
2330 lvalue->symtree->n.sym->name, &lvalue->where);
2335 /* Check INTENT(IN), unless the object itself is the component or
2336 sub-component of a pointer. */
2337 check_intent_in = 1;
2338 pointer = lvalue->symtree->n.sym->attr.pointer;
2340 for (ref = lvalue->ref; ref; ref = ref->next)
2343 check_intent_in = 0;
2345 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2349 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
2351 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2352 lvalue->symtree->n.sym->name, &lvalue->where);
2358 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
2362 is_pure = gfc_pure (NULL);
2364 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
2366 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
2370 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2371 kind, etc for lvalue and rvalue must match, and rvalue must be a
2372 pure variable if we're in a pure function. */
2373 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
2376 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
2378 gfc_error ("Different types in pointer assignment at %L",
2383 if (lvalue->ts.kind != rvalue->ts.kind)
2385 gfc_error ("Different kind type parameters in pointer "
2386 "assignment at %L", &lvalue->where);
2390 if (lvalue->rank != rvalue->rank)
2392 gfc_error ("Different ranks in pointer assignment at %L",
2397 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2398 if (rvalue->expr_type == EXPR_NULL)
2401 if (lvalue->ts.type == BT_CHARACTER
2402 && lvalue->ts.cl->length && rvalue->ts.cl->length
2403 && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2404 rvalue->ts.cl->length)) == 1)
2406 gfc_error ("Different character lengths in pointer "
2407 "assignment at %L", &lvalue->where);
2411 attr = gfc_expr_attr (rvalue);
2412 if (!attr.target && !attr.pointer)
2414 gfc_error ("Pointer assignment target is neither TARGET "
2415 "nor POINTER at %L", &rvalue->where);
2419 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2421 gfc_error ("Bad target in pointer assignment in PURE "
2422 "procedure at %L", &rvalue->where);
2425 if (gfc_has_vector_index (rvalue))
2427 gfc_error ("Pointer assignment with vector subscript "
2428 "on rhs at %L", &rvalue->where);
2432 if (attr.protected && attr.use_assoc)
2434 gfc_error ("Pointer assigment target has PROTECTED "
2435 "attribute at %L", &rvalue->where);
2443 /* Relative of gfc_check_assign() except that the lvalue is a single
2444 symbol. Used for initialization assignments. */
2447 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
2452 memset (&lvalue, '\0', sizeof (gfc_expr));
2454 lvalue.expr_type = EXPR_VARIABLE;
2455 lvalue.ts = sym->ts;
2457 lvalue.rank = sym->as->rank;
2458 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
2459 lvalue.symtree->n.sym = sym;
2460 lvalue.where = sym->declared_at;
2462 if (sym->attr.pointer)
2463 r = gfc_check_pointer_assign (&lvalue, rvalue);
2465 r = gfc_check_assign (&lvalue, rvalue, 1);
2467 gfc_free (lvalue.symtree);
2473 /* Get an expression for a default initializer. */
2476 gfc_default_initializer (gfc_typespec *ts)
2478 gfc_constructor *tail;
2484 /* See if we have a default initializer. */
2485 for (c = ts->derived->components; c; c = c->next)
2487 if ((c->initializer || c->allocatable) && init == NULL)
2488 init = gfc_get_expr ();
2494 /* Build the constructor. */
2495 init->expr_type = EXPR_STRUCTURE;
2497 init->where = ts->derived->declared_at;
2499 for (c = ts->derived->components; c; c = c->next)
2502 init->value.constructor = tail = gfc_get_constructor ();
2505 tail->next = gfc_get_constructor ();
2510 tail->expr = gfc_copy_expr (c->initializer);
2514 tail->expr = gfc_get_expr ();
2515 tail->expr->expr_type = EXPR_NULL;
2516 tail->expr->ts = c->ts;
2523 /* Given a symbol, create an expression node with that symbol as a
2524 variable. If the symbol is array valued, setup a reference of the
2528 gfc_get_variable_expr (gfc_symtree *var)
2532 e = gfc_get_expr ();
2533 e->expr_type = EXPR_VARIABLE;
2535 e->ts = var->n.sym->ts;
2537 if (var->n.sym->as != NULL)
2539 e->rank = var->n.sym->as->rank;
2540 e->ref = gfc_get_ref ();
2541 e->ref->type = REF_ARRAY;
2542 e->ref->u.ar.type = AR_FULL;
2549 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2552 gfc_expr_set_symbols_referenced (gfc_expr *expr)
2554 gfc_actual_arglist *arg;
2561 switch (expr->expr_type)
2564 gfc_expr_set_symbols_referenced (expr->value.op.op1);
2565 gfc_expr_set_symbols_referenced (expr->value.op.op2);
2569 for (arg = expr->value.function.actual; arg; arg = arg->next)
2570 gfc_expr_set_symbols_referenced (arg->expr);
2574 gfc_set_sym_referenced (expr->symtree->n.sym);
2579 case EXPR_SUBSTRING:
2582 case EXPR_STRUCTURE:
2584 for (c = expr->value.constructor; c; c = c->next)
2585 gfc_expr_set_symbols_referenced (c->expr);
2593 for (ref = expr->ref; ref; ref = ref->next)
2597 for (i = 0; i < ref->u.ar.dimen; i++)
2599 gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2600 gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2601 gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2609 gfc_expr_set_symbols_referenced (ref->u.ss.start);
2610 gfc_expr_set_symbols_referenced (ref->u.ss.end);