1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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));
38 gfc_clear_ts (&e->ts);
42 e->con_by_offset = NULL;
47 /* Free an argument list and everything below it. */
50 gfc_free_actual_arglist (gfc_actual_arglist * a1)
52 gfc_actual_arglist *a2;
57 gfc_free_expr (a1->expr);
64 /* Copy an arglist structure and all of the arguments. */
67 gfc_copy_actual_arglist (gfc_actual_arglist * p)
69 gfc_actual_arglist *head, *tail, *new;
73 for (; p; p = p->next)
75 new = gfc_get_actual_arglist ();
78 new->expr = gfc_copy_expr (p->expr);
93 /* Free a list of reference structures. */
96 gfc_free_ref_list (gfc_ref * p)
108 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
110 gfc_free_expr (p->u.ar.start[i]);
111 gfc_free_expr (p->u.ar.end[i]);
112 gfc_free_expr (p->u.ar.stride[i]);
118 gfc_free_expr (p->u.ss.start);
119 gfc_free_expr (p->u.ss.end);
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
137 free_expr0 (gfc_expr * e)
141 switch (e->expr_type)
146 gfc_free (e->value.character.string);
153 mpz_clear (e->value.integer);
157 mpfr_clear (e->value.real);
162 gfc_free (e->value.character.string);
166 mpfr_clear (e->value.complex.r);
167 mpfr_clear (e->value.complex.i);
177 if (e->value.op.op1 != NULL)
178 gfc_free_expr (e->value.op.op1);
179 if (e->value.op.op2 != NULL)
180 gfc_free_expr (e->value.op.op2);
184 gfc_free_actual_arglist (e->value.function.actual);
192 gfc_free_constructor (e->value.constructor);
196 gfc_free (e->value.character.string);
203 gfc_internal_error ("free_expr0(): Bad expr type");
206 /* Free a shape array. */
207 if (e->shape != NULL)
209 for (n = 0; n < e->rank; n++)
210 mpz_clear (e->shape[n]);
215 gfc_free_ref_list (e->ref);
217 memset (e, '\0', sizeof (gfc_expr));
221 /* Free an expression node and everything beneath it. */
224 gfc_free_expr (gfc_expr * e)
229 if (e->con_by_offset)
230 splay_tree_delete (e->con_by_offset);
236 /* Graft the *src expression onto the *dest subexpression. */
239 gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
249 /* Try to extract an integer constant from the passed expression node.
250 Returns an error message or NULL if the result is set. It is
251 tempting to generate an error and return SUCCESS or FAILURE, but
252 failure is OK for some callers. */
255 gfc_extract_int (gfc_expr * expr, int *result)
258 if (expr->expr_type != EXPR_CONSTANT)
259 return _("Constant expression required at %C");
261 if (expr->ts.type != BT_INTEGER)
262 return _("Integer expression required at %C");
264 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
265 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
267 return _("Integer value too large in expression at %C");
270 *result = (int) mpz_get_si (expr->value.integer);
276 /* Recursively copy a list of reference structures. */
279 copy_ref (gfc_ref * src)
287 dest = gfc_get_ref ();
288 dest->type = src->type;
293 ar = gfc_copy_array_ref (&src->u.ar);
299 dest->u.c = src->u.c;
303 dest->u.ss = src->u.ss;
304 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
305 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
309 dest->next = copy_ref (src->next);
315 /* Detect whether an expression has any vector index array
319 gfc_has_vector_index (gfc_expr *e)
323 for (ref = e->ref; ref; ref = ref->next)
324 if (ref->type == REF_ARRAY)
325 for (i = 0; i < ref->u.ar.dimen; i++)
326 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
332 /* Copy a shape array. */
335 gfc_copy_shape (mpz_t * shape, int rank)
343 new_shape = gfc_get_shape (rank);
345 for (n = 0; n < rank; n++)
346 mpz_init_set (new_shape[n], shape[n]);
352 /* Copy a shape array excluding dimension N, where N is an integer
353 constant expression. Dimensions are numbered in fortran style --
356 So, if the original shape array contains R elements
357 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
358 the result contains R-1 elements:
359 { s1 ... sN-1 sN+1 ... sR-1}
361 If anything goes wrong -- N is not a constant, its value is out
362 of range -- or anything else, just returns NULL.
366 gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
368 mpz_t *new_shape, *s;
374 || dim->expr_type != EXPR_CONSTANT
375 || dim->ts.type != BT_INTEGER)
378 n = mpz_get_si (dim->value.integer);
379 n--; /* Convert to zero based index */
380 if (n < 0 || n >= rank)
383 s = new_shape = gfc_get_shape (rank-1);
385 for (i = 0; i < rank; i++)
389 mpz_init_set (*s, shape[i]);
396 /* Given an expression pointer, return a copy of the expression. This
397 subroutine is recursive. */
400 gfc_copy_expr (gfc_expr * p)
411 switch (q->expr_type)
414 s = gfc_getmem (p->value.character.length + 1);
415 q->value.character.string = s;
417 memcpy (s, p->value.character.string, p->value.character.length + 1);
423 s = gfc_getmem (p->value.character.length + 1);
424 q->value.character.string = s;
426 memcpy (s, p->value.character.string,
427 p->value.character.length + 1);
433 mpz_init_set (q->value.integer, p->value.integer);
437 gfc_set_model_kind (q->ts.kind);
438 mpfr_init (q->value.real);
439 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
443 gfc_set_model_kind (q->ts.kind);
444 mpfr_init (q->value.complex.r);
445 mpfr_init (q->value.complex.i);
446 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
447 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
452 s = gfc_getmem (p->value.character.length + 1);
453 q->value.character.string = s;
455 memcpy (s, p->value.character.string,
456 p->value.character.length + 1);
461 break; /* Already done */
465 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
472 switch (q->value.op.operator)
475 case INTRINSIC_UPLUS:
476 case INTRINSIC_UMINUS:
477 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
480 default: /* Binary operators */
481 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
482 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
489 q->value.function.actual =
490 gfc_copy_actual_arglist (p->value.function.actual);
495 q->value.constructor = gfc_copy_constructor (p->value.constructor);
503 q->shape = gfc_copy_shape (p->shape, p->rank);
505 q->ref = copy_ref (p->ref);
511 /* Return the maximum kind of two expressions. In general, higher
512 kind numbers mean more precision for numeric types. */
515 gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
518 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
522 /* Returns nonzero if the type is numeric, zero otherwise. */
525 numeric_type (bt type)
528 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
532 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
535 gfc_numeric_ts (gfc_typespec * ts)
538 return numeric_type (ts->type);
542 /* Returns an expression node that is an integer constant. */
551 p->expr_type = EXPR_CONSTANT;
552 p->ts.type = BT_INTEGER;
553 p->ts.kind = gfc_default_integer_kind;
555 p->where = gfc_current_locus;
556 mpz_init_set_si (p->value.integer, i);
562 /* Returns an expression node that is a logical constant. */
565 gfc_logical_expr (int i, locus * where)
571 p->expr_type = EXPR_CONSTANT;
572 p->ts.type = BT_LOGICAL;
573 p->ts.kind = gfc_default_logical_kind;
576 where = &gfc_current_locus;
578 p->value.logical = i;
584 /* Return an expression node with an optional argument list attached.
585 A variable number of gfc_expr pointers are strung together in an
586 argument list with a NULL pointer terminating the list. */
589 gfc_build_conversion (gfc_expr * e)
594 p->expr_type = EXPR_FUNCTION;
596 p->value.function.actual = NULL;
598 p->value.function.actual = gfc_get_actual_arglist ();
599 p->value.function.actual->expr = e;
605 /* Given an expression node with some sort of numeric binary
606 expression, insert type conversions required to make the operands
609 The exception is that the operands of an exponential don't have to
610 have the same type. If possible, the base is promoted to the type
611 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
612 1.0**2 stays as it is. */
615 gfc_type_convert_binary (gfc_expr * e)
619 op1 = e->value.op.op1;
620 op2 = e->value.op.op2;
622 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
624 gfc_clear_ts (&e->ts);
628 /* Kind conversions of same type. */
629 if (op1->ts.type == op2->ts.type)
632 if (op1->ts.kind == op2->ts.kind)
634 /* No type conversions. */
639 if (op1->ts.kind > op2->ts.kind)
640 gfc_convert_type (op2, &op1->ts, 2);
642 gfc_convert_type (op1, &op2->ts, 2);
648 /* Integer combined with real or complex. */
649 if (op2->ts.type == BT_INTEGER)
653 /* Special case for ** operator. */
654 if (e->value.op.operator == INTRINSIC_POWER)
657 gfc_convert_type (e->value.op.op2, &e->ts, 2);
661 if (op1->ts.type == BT_INTEGER)
664 gfc_convert_type (e->value.op.op1, &e->ts, 2);
668 /* Real combined with complex. */
669 e->ts.type = BT_COMPLEX;
670 if (op1->ts.kind > op2->ts.kind)
671 e->ts.kind = op1->ts.kind;
673 e->ts.kind = op2->ts.kind;
674 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
675 gfc_convert_type (e->value.op.op1, &e->ts, 2);
676 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
677 gfc_convert_type (e->value.op.op2, &e->ts, 2);
684 /* Function to determine if an expression is constant or not. This
685 function expects that the expression has already been simplified. */
688 gfc_is_constant_expr (gfc_expr * e)
691 gfc_actual_arglist *arg;
697 switch (e->expr_type)
700 rv = (gfc_is_constant_expr (e->value.op.op1)
701 && (e->value.op.op2 == NULL
702 || gfc_is_constant_expr (e->value.op.op2)));
711 /* Call to intrinsic with at least one argument. */
713 if (e->value.function.isym && e->value.function.actual)
715 for (arg = e->value.function.actual; arg; arg = arg->next)
717 if (!gfc_is_constant_expr (arg->expr))
731 rv = (gfc_is_constant_expr (e->ref->u.ss.start)
732 && gfc_is_constant_expr (e->ref->u.ss.end));
737 for (c = e->value.constructor; c; c = c->next)
738 if (!gfc_is_constant_expr (c->expr))
746 rv = gfc_constant_ac (e);
750 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
757 /* Try to collapse intrinsic expressions. */
760 simplify_intrinsic_op (gfc_expr * p, int type)
762 gfc_expr *op1, *op2, *result;
764 if (p->value.op.operator == INTRINSIC_USER)
767 op1 = p->value.op.op1;
768 op2 = p->value.op.op2;
770 if (gfc_simplify_expr (op1, type) == FAILURE)
772 if (gfc_simplify_expr (op2, type) == FAILURE)
775 if (!gfc_is_constant_expr (op1)
776 || (op2 != NULL && !gfc_is_constant_expr (op2)))
780 p->value.op.op1 = NULL;
781 p->value.op.op2 = NULL;
783 switch (p->value.op.operator)
785 case INTRINSIC_UPLUS:
786 case INTRINSIC_PARENTHESES:
787 result = gfc_uplus (op1);
790 case INTRINSIC_UMINUS:
791 result = gfc_uminus (op1);
795 result = gfc_add (op1, op2);
798 case INTRINSIC_MINUS:
799 result = gfc_subtract (op1, op2);
802 case INTRINSIC_TIMES:
803 result = gfc_multiply (op1, op2);
806 case INTRINSIC_DIVIDE:
807 result = gfc_divide (op1, op2);
810 case INTRINSIC_POWER:
811 result = gfc_power (op1, op2);
814 case INTRINSIC_CONCAT:
815 result = gfc_concat (op1, op2);
819 result = gfc_eq (op1, op2);
823 result = gfc_ne (op1, op2);
827 result = gfc_gt (op1, op2);
831 result = gfc_ge (op1, op2);
835 result = gfc_lt (op1, op2);
839 result = gfc_le (op1, op2);
843 result = gfc_not (op1);
847 result = gfc_and (op1, op2);
851 result = gfc_or (op1, op2);
855 result = gfc_eqv (op1, op2);
859 result = gfc_neqv (op1, op2);
863 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
873 result->rank = p->rank;
874 result->where = p->where;
875 gfc_replace_expr (p, result);
881 /* Subroutine to simplify constructor expressions. Mutually recursive
882 with gfc_simplify_expr(). */
885 simplify_constructor (gfc_constructor * c, int type)
888 for (; c; c = c->next)
891 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
892 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
893 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
896 if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
904 /* Pull a single array element out of an array constructor. */
907 find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
908 gfc_constructor ** rval)
910 unsigned long nelemen;
920 mpz_init_set_ui (offset, 0);
922 for (i = 0; i < ar->dimen; i++)
924 e = gfc_copy_expr (ar->start[i]);
925 if (e->expr_type != EXPR_CONSTANT)
931 /* Check the bounds. */
933 && (mpz_cmp (e->value.integer,
934 ar->as->upper[i]->value.integer) > 0
935 || mpz_cmp (e->value.integer,
936 ar->as->lower[i]->value.integer) < 0))
938 gfc_error ("index in dimension %d is out of bounds "
939 "at %L", i + 1, &ar->c_where[i]);
945 mpz_sub (delta, e->value.integer,
946 ar->as->lower[i]->value.integer);
947 mpz_add (offset, offset, delta);
952 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
973 /* Find a component of a structure constructor. */
975 static gfc_constructor *
976 find_component_ref (gfc_constructor * cons, gfc_ref * ref)
981 comp = ref->u.c.sym->components;
982 pick = ref->u.c.component;
993 /* Replace an expression with the contents of a constructor, removing
994 the subobject reference in the process. */
997 remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
1003 e->ref = p->ref->next;
1004 p->ref->next = NULL;
1005 gfc_replace_expr (p, e);
1009 /* Pull an array section out of an array constructor. */
1012 find_array_section (gfc_expr *expr, gfc_ref *ref)
1018 long unsigned one = 1;
1020 mpz_t start[GFC_MAX_DIMENSIONS];
1021 mpz_t end[GFC_MAX_DIMENSIONS];
1022 mpz_t stride[GFC_MAX_DIMENSIONS];
1023 mpz_t delta[GFC_MAX_DIMENSIONS];
1024 mpz_t ctr[GFC_MAX_DIMENSIONS];
1030 gfc_constructor *cons;
1031 gfc_constructor *base;
1037 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1042 base = expr->value.constructor;
1043 expr->value.constructor = NULL;
1045 rank = ref->u.ar.as->rank;
1047 if (expr->shape == NULL)
1048 expr->shape = gfc_get_shape (rank);
1050 mpz_init_set_ui (delta_mpz, one);
1051 mpz_init_set_ui (nelts, one);
1054 /* Do the initialization now, so that we can cleanup without
1055 keeping track of where we were. */
1056 for (d = 0; d < rank; d++)
1058 mpz_init (delta[d]);
1059 mpz_init (start[d]);
1062 mpz_init (stride[d]);
1066 /* Build the counters to clock through the array reference. */
1068 for (d = 0; d < rank; d++)
1070 /* Make this stretch of code easier on the eye! */
1071 begin = ref->u.ar.start[d];
1072 finish = ref->u.ar.end[d];
1073 step = ref->u.ar.stride[d];
1074 lower = ref->u.ar.as->lower[d];
1075 upper = ref->u.ar.as->upper[d];
1077 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1080 gcc_assert(begin->expr_type == EXPR_ARRAY);
1081 gcc_assert(begin->rank == 1);
1082 gcc_assert(begin->shape);
1084 vecsub[d] = begin->value.constructor;
1085 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1086 mpz_mul (nelts, nelts, begin->shape[0]);
1087 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1090 for (c = vecsub[d]; c; c = c->next)
1092 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1093 || mpz_cmp (c->expr->value.integer, lower->value.integer) < 0)
1095 gfc_error ("index in dimension %d is out of bounds "
1096 "at %L", d + 1, &ref->u.ar.c_where[d]);
1104 if ((begin && begin->expr_type != EXPR_CONSTANT)
1105 || (finish && finish->expr_type != EXPR_CONSTANT)
1106 || (step && step->expr_type != EXPR_CONSTANT))
1112 /* Obtain the stride. */
1114 mpz_set (stride[d], step->value.integer);
1116 mpz_set_ui (stride[d], one);
1118 if (mpz_cmp_ui (stride[d], 0) == 0)
1119 mpz_set_ui (stride[d], one);
1121 /* Obtain the start value for the index. */
1123 mpz_set (start[d], begin->value.integer);
1125 mpz_set (start[d], lower->value.integer);
1127 mpz_set (ctr[d], start[d]);
1129 /* Obtain the end value for the index. */
1131 mpz_set (end[d], finish->value.integer);
1133 mpz_set (end[d], upper->value.integer);
1135 /* Separate 'if' because elements sometimes arrive with
1137 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1138 mpz_set (end [d], begin->value.integer);
1140 /* Check the bounds. */
1141 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1142 || mpz_cmp (end[d], upper->value.integer) > 0
1143 || mpz_cmp (ctr[d], lower->value.integer) < 0
1144 || mpz_cmp (end[d], lower->value.integer) < 0)
1146 gfc_error ("index in dimension %d is out of bounds "
1147 "at %L", d + 1, &ref->u.ar.c_where[d]);
1152 /* Calculate the number of elements and the shape. */
1153 mpz_abs (tmp_mpz, stride[d]);
1154 mpz_div (tmp_mpz, stride[d], tmp_mpz);
1155 mpz_add (tmp_mpz, end[d], tmp_mpz);
1156 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1157 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1158 mpz_mul (nelts, nelts, tmp_mpz);
1160 /* An element reference reduces the rank of the expression; don't add
1161 anything to the shape array. */
1162 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1163 mpz_set (expr->shape[shape_i++], tmp_mpz);
1166 /* Calculate the 'stride' (=delta) for conversion of the
1167 counter values into the index along the constructor. */
1168 mpz_set (delta[d], delta_mpz);
1169 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1170 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1171 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1178 /* Now clock through the array reference, calculating the index in
1179 the source constructor and transferring the elements to the new
1181 for (idx = 0; idx < (int)mpz_get_si (nelts); idx++)
1183 if (ref->u.ar.offset)
1184 mpz_set (ptr, ref->u.ar.offset->value.integer);
1186 mpz_init_set_ui (ptr, 0);
1189 for (d = 0; d < rank; d++)
1191 mpz_set (tmp_mpz, ctr[d]);
1192 mpz_sub (tmp_mpz, tmp_mpz,
1193 ref->u.ar.as->lower[d]->value.integer);
1194 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1195 mpz_add (ptr, ptr, tmp_mpz);
1197 if (!incr_ctr) continue;
1199 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1201 gcc_assert(vecsub[d]);
1203 if (!vecsub[d]->next)
1204 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1207 vecsub[d] = vecsub[d]->next;
1210 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1214 mpz_add (ctr[d], ctr[d], stride[d]);
1216 if (mpz_cmp_ui (stride[d], 0) > 0 ?
1217 mpz_cmp (ctr[d], end[d]) > 0 :
1218 mpz_cmp (ctr[d], end[d]) < 0)
1219 mpz_set (ctr[d], start[d]);
1225 /* There must be a better way of dealing with negative strides
1226 than resetting the index and the constructor pointer! */
1227 if (mpz_cmp (ptr, index) < 0)
1229 mpz_set_ui (index, 0);
1233 while (mpz_cmp (ptr, index) > 0)
1235 mpz_add_ui (index, index, one);
1239 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1247 mpz_clear (delta_mpz);
1248 mpz_clear (tmp_mpz);
1250 for (d = 0; d < rank; d++)
1252 mpz_clear (delta[d]);
1253 mpz_clear (start[d]);
1256 mpz_clear (stride[d]);
1258 gfc_free_constructor (base);
1262 /* Pull a substring out of an expression. */
1265 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1271 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1272 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1275 *newp = gfc_copy_expr (p);
1276 chr = p->value.character.string;
1277 end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer);
1278 start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer);
1280 (*newp)->value.character.length = end - start + 1;
1281 strncpy ((*newp)->value.character.string, &chr[start - 1],
1282 (*newp)->value.character.length);
1288 /* Simplify a subobject reference of a constructor. This occurs when
1289 parameter variable values are substituted. */
1292 simplify_const_ref (gfc_expr * p)
1294 gfc_constructor *cons;
1299 switch (p->ref->type)
1302 switch (p->ref->u.ar.type)
1305 if (find_array_element (p->value.constructor,
1313 remove_subobject_ref (p, cons);
1317 if (find_array_section (p, p->ref) == FAILURE)
1319 p->ref->u.ar.type = AR_FULL;
1324 if (p->ref->next != NULL
1325 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1327 cons = p->value.constructor;
1328 for (; cons; cons = cons->next)
1330 cons->expr->ref = copy_ref (p->ref->next);
1331 simplify_const_ref (cons->expr);
1334 gfc_free_ref_list (p->ref);
1345 cons = find_component_ref (p->value.constructor, p->ref);
1346 remove_subobject_ref (p, cons);
1350 if (find_substring_ref (p, &newp) == FAILURE)
1353 gfc_replace_expr (p, newp);
1354 gfc_free_ref_list (p->ref);
1364 /* Simplify a chain of references. */
1367 simplify_ref_chain (gfc_ref * ref, int type)
1371 for (; ref; ref = ref->next)
1376 for (n = 0; n < ref->u.ar.dimen; n++)
1378 if (gfc_simplify_expr (ref->u.ar.start[n], type)
1381 if (gfc_simplify_expr (ref->u.ar.end[n], type)
1384 if (gfc_simplify_expr (ref->u.ar.stride[n], type)
1392 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1394 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1406 /* Try to substitute the value of a parameter variable. */
1408 simplify_parameter_variable (gfc_expr * p, int type)
1413 e = gfc_copy_expr (p->symtree->n.sym->value);
1419 /* Do not copy subobject refs for constant. */
1420 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1421 e->ref = copy_ref (p->ref);
1422 t = gfc_simplify_expr (e, type);
1424 /* Only use the simplification if it eliminated all subobject
1426 if (t == SUCCESS && ! e->ref)
1427 gfc_replace_expr (p, e);
1434 /* Given an expression, simplify it by collapsing constant
1435 expressions. Most simplification takes place when the expression
1436 tree is being constructed. If an intrinsic function is simplified
1437 at some point, we get called again to collapse the result against
1440 We work by recursively simplifying expression nodes, simplifying
1441 intrinsic functions where possible, which can lead to further
1442 constant collapsing. If an operator has constant operand(s), we
1443 rip the expression apart, and rebuild it, hoping that it becomes
1446 The expression type is defined for:
1447 0 Basic expression parsing
1448 1 Simplifying array constructors -- will substitute
1450 Returns FAILURE on error, SUCCESS otherwise.
1451 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1454 gfc_simplify_expr (gfc_expr * p, int type)
1456 gfc_actual_arglist *ap;
1461 switch (p->expr_type)
1468 for (ap = p->value.function.actual; ap; ap = ap->next)
1469 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1472 if (p->value.function.isym != NULL
1473 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1478 case EXPR_SUBSTRING:
1479 if (simplify_ref_chain (p->ref, type) == FAILURE)
1482 if (gfc_is_constant_expr (p))
1487 gfc_extract_int (p->ref->u.ss.start, &start);
1488 start--; /* Convert from one-based to zero-based. */
1489 gfc_extract_int (p->ref->u.ss.end, &end);
1490 s = gfc_getmem (end - start + 2);
1491 memcpy (s, p->value.character.string + start, end - start);
1492 s[end-start+1] = '\0'; /* TODO: C-style string for debugging. */
1493 gfc_free (p->value.character.string);
1494 p->value.character.string = s;
1495 p->value.character.length = end - start;
1496 p->ts.cl = gfc_get_charlen ();
1497 p->ts.cl->next = gfc_current_ns->cl_list;
1498 gfc_current_ns->cl_list = p->ts.cl;
1499 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1500 gfc_free_ref_list (p->ref);
1502 p->expr_type = EXPR_CONSTANT;
1507 if (simplify_intrinsic_op (p, type) == FAILURE)
1512 /* Only substitute array parameter variables if we are in an
1513 initialization expression, or we want a subsection. */
1514 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1515 && (gfc_init_expr || p->ref
1516 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1518 if (simplify_parameter_variable (p, type) == FAILURE)
1525 gfc_simplify_iterator_var (p);
1528 /* Simplify subcomponent references. */
1529 if (simplify_ref_chain (p->ref, type) == FAILURE)
1534 case EXPR_STRUCTURE:
1536 if (simplify_ref_chain (p->ref, type) == FAILURE)
1539 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1542 if (p->expr_type == EXPR_ARRAY
1543 && p->ref && p->ref->type == REF_ARRAY
1544 && p->ref->u.ar.type == AR_FULL)
1545 gfc_expand_constructor (p);
1547 if (simplify_const_ref (p) == FAILURE)
1557 /* Returns the type of an expression with the exception that iterator
1558 variables are automatically integers no matter what else they may
1565 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1572 /* Check an intrinsic arithmetic operation to see if it is consistent
1573 with some type of expression. */
1575 static try check_init_expr (gfc_expr *);
1578 check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
1580 gfc_expr *op1 = e->value.op.op1;
1581 gfc_expr *op2 = e->value.op.op2;
1583 if ((*check_function) (op1) == FAILURE)
1586 switch (e->value.op.operator)
1588 case INTRINSIC_UPLUS:
1589 case INTRINSIC_UMINUS:
1590 if (!numeric_type (et0 (op1)))
1600 if ((*check_function) (op2) == FAILURE)
1603 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1604 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1606 gfc_error ("Numeric or CHARACTER operands are required in "
1607 "expression at %L", &e->where);
1612 case INTRINSIC_PLUS:
1613 case INTRINSIC_MINUS:
1614 case INTRINSIC_TIMES:
1615 case INTRINSIC_DIVIDE:
1616 case INTRINSIC_POWER:
1617 if ((*check_function) (op2) == FAILURE)
1620 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1623 if (e->value.op.operator == INTRINSIC_POWER
1624 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1626 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1627 "exponent in an initialization "
1628 "expression at %L", &op2->where)
1635 case INTRINSIC_CONCAT:
1636 if ((*check_function) (op2) == FAILURE)
1639 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1641 gfc_error ("Concatenation operator in expression at %L "
1642 "must have two CHARACTER operands", &op1->where);
1646 if (op1->ts.kind != op2->ts.kind)
1648 gfc_error ("Concat operator at %L must concatenate strings of the "
1649 "same kind", &e->where);
1656 if (et0 (op1) != BT_LOGICAL)
1658 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1659 "operand", &op1->where);
1668 case INTRINSIC_NEQV:
1669 if ((*check_function) (op2) == FAILURE)
1672 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1674 gfc_error ("LOGICAL operands are required in expression at %L",
1681 case INTRINSIC_PARENTHESES:
1685 gfc_error ("Only intrinsic operators can be used in expression at %L",
1693 gfc_error ("Numeric operands are required in expression at %L", &e->where);
1700 /* Certain inquiry functions are specifically allowed to have variable
1701 arguments, which is an exception to the normal requirement that an
1702 initialization function have initialization arguments. We head off
1703 this problem here. */
1706 check_inquiry (gfc_expr * e, int not_restricted)
1710 /* FIXME: This should be moved into the intrinsic definitions,
1711 to eliminate this ugly hack. */
1712 static const char * const inquiry_function[] = {
1713 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1714 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1715 "lbound", "ubound", NULL
1720 /* An undeclared parameter will get us here (PR25018). */
1721 if (e->symtree == NULL)
1724 name = e->symtree->n.sym->name;
1726 for (i = 0; inquiry_function[i]; i++)
1727 if (strcmp (inquiry_function[i], name) == 0)
1730 if (inquiry_function[i] == NULL)
1733 e = e->value.function.actual->expr;
1735 if (e == NULL || e->expr_type != EXPR_VARIABLE)
1738 /* At this point we have an inquiry function with a variable argument. The
1739 type of the variable might be undefined, but we need it now, because the
1740 arguments of these functions are allowed to be undefined. */
1742 if (e->ts.type == BT_UNKNOWN)
1744 if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1745 && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1749 e->ts = e->symtree->n.sym->ts;
1752 /* Assumed character length will not reduce to a constant expression
1753 with LEN, as required by the standard. */
1754 if (i == 4 && not_restricted
1755 && e->symtree->n.sym->ts.type == BT_CHARACTER
1756 && e->symtree->n.sym->ts.cl->length == NULL)
1757 gfc_notify_std (GFC_STD_GNU, "assumed character length "
1758 "variable '%s' in constant expression at %L",
1759 e->symtree->n.sym->name, &e->where);
1765 /* Verify that an expression is an initialization expression. A side
1766 effect is that the expression tree is reduced to a single constant
1767 node if all goes well. This would normally happen when the
1768 expression is constructed but function references are assumed to be
1769 intrinsics in the context of initialization expressions. If
1770 FAILURE is returned an error message has been generated. */
1773 check_init_expr (gfc_expr * e)
1775 gfc_actual_arglist *ap;
1782 switch (e->expr_type)
1785 t = check_intrinsic_op (e, check_init_expr);
1787 t = gfc_simplify_expr (e, 0);
1794 if (check_inquiry (e, 1) != SUCCESS)
1797 for (ap = e->value.function.actual; ap; ap = ap->next)
1798 if (check_init_expr (ap->expr) == FAILURE)
1807 m = gfc_intrinsic_func_interface (e, 0);
1810 gfc_error ("Function '%s' in initialization expression at %L "
1811 "must be an intrinsic function",
1812 e->symtree->n.sym->name, &e->where);
1823 if (gfc_check_iter_variable (e) == SUCCESS)
1826 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1828 t = simplify_parameter_variable (e, 0);
1832 if (gfc_in_match_data ())
1835 gfc_error ("Parameter '%s' at %L has not been declared or is "
1836 "a variable, which does not reduce to a constant "
1837 "expression", e->symtree->n.sym->name, &e->where);
1846 case EXPR_SUBSTRING:
1847 t = check_init_expr (e->ref->u.ss.start);
1851 t = check_init_expr (e->ref->u.ss.end);
1853 t = gfc_simplify_expr (e, 0);
1857 case EXPR_STRUCTURE:
1858 t = gfc_check_constructor (e, check_init_expr);
1862 t = gfc_check_constructor (e, check_init_expr);
1866 t = gfc_expand_constructor (e);
1870 t = gfc_check_constructor_type (e);
1874 gfc_internal_error ("check_init_expr(): Unknown expression type");
1881 /* Match an initialization expression. We work by first matching an
1882 expression, then reducing it to a constant. */
1885 gfc_match_init_expr (gfc_expr ** result)
1891 m = gfc_match_expr (&expr);
1896 t = gfc_resolve_expr (expr);
1898 t = check_init_expr (expr);
1903 gfc_free_expr (expr);
1907 if (expr->expr_type == EXPR_ARRAY
1908 && (gfc_check_constructor_type (expr) == FAILURE
1909 || gfc_expand_constructor (expr) == FAILURE))
1911 gfc_free_expr (expr);
1915 /* Not all inquiry functions are simplified to constant expressions
1916 so it is necessary to call check_inquiry again. */
1917 if (!gfc_is_constant_expr (expr)
1918 && check_inquiry (expr, 1) == FAILURE
1919 && !gfc_in_match_data ())
1921 gfc_error ("Initialization expression didn't reduce %C");
1932 static try check_restricted (gfc_expr *);
1934 /* Given an actual argument list, test to see that each argument is a
1935 restricted expression and optionally if the expression type is
1936 integer or character. */
1939 restricted_args (gfc_actual_arglist * a)
1941 for (; a; a = a->next)
1943 if (check_restricted (a->expr) == FAILURE)
1951 /************* Restricted/specification expressions *************/
1954 /* Make sure a non-intrinsic function is a specification function. */
1957 external_spec_function (gfc_expr * e)
1961 f = e->value.function.esym;
1963 if (f->attr.proc == PROC_ST_FUNCTION)
1965 gfc_error ("Specification function '%s' at %L cannot be a statement "
1966 "function", f->name, &e->where);
1970 if (f->attr.proc == PROC_INTERNAL)
1972 gfc_error ("Specification function '%s' at %L cannot be an internal "
1973 "function", f->name, &e->where);
1977 if (!f->attr.pure && !f->attr.elemental)
1979 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1984 if (f->attr.recursive)
1986 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1987 f->name, &e->where);
1991 return restricted_args (e->value.function.actual);
1995 /* Check to see that a function reference to an intrinsic is a
1996 restricted expression. */
1999 restricted_intrinsic (gfc_expr * e)
2001 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2002 if (check_inquiry (e, 0) == SUCCESS)
2005 return restricted_args (e->value.function.actual);
2009 /* Verify that an expression is a restricted expression. Like its
2010 cousin check_init_expr(), an error message is generated if we
2014 check_restricted (gfc_expr * e)
2022 switch (e->expr_type)
2025 t = check_intrinsic_op (e, check_restricted);
2027 t = gfc_simplify_expr (e, 0);
2032 t = e->value.function.esym ?
2033 external_spec_function (e) : restricted_intrinsic (e);
2038 sym = e->symtree->n.sym;
2041 if (sym->attr.optional)
2043 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2044 sym->name, &e->where);
2048 if (sym->attr.intent == INTENT_OUT)
2050 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2051 sym->name, &e->where);
2055 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
2056 in resolve.c(resolve_formal_arglist). This is done so that host associated
2057 dummy array indices are accepted (PR23446). This mechanism also does the
2058 same for the specification expressions of array-valued functions. */
2059 if (sym->attr.in_common
2060 || sym->attr.use_assoc
2062 || sym->ns != gfc_current_ns
2063 || (sym->ns->proc_name != NULL
2064 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2065 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2071 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2072 sym->name, &e->where);
2081 case EXPR_SUBSTRING:
2082 t = gfc_specification_expr (e->ref->u.ss.start);
2086 t = gfc_specification_expr (e->ref->u.ss.end);
2088 t = gfc_simplify_expr (e, 0);
2092 case EXPR_STRUCTURE:
2093 t = gfc_check_constructor (e, check_restricted);
2097 t = gfc_check_constructor (e, check_restricted);
2101 gfc_internal_error ("check_restricted(): Unknown expression type");
2108 /* Check to see that an expression is a specification expression. If
2109 we return FAILURE, an error has been generated. */
2112 gfc_specification_expr (gfc_expr * e)
2117 if (e->ts.type != BT_INTEGER)
2119 gfc_error ("Expression at %L must be of INTEGER type", &e->where);
2125 gfc_error ("Expression at %L must be scalar", &e->where);
2129 if (gfc_simplify_expr (e, 0) == FAILURE)
2132 return check_restricted (e);
2136 /************** Expression conformance checks. *************/
2138 /* Given two expressions, make sure that the arrays are conformable. */
2141 gfc_check_conformance (const char *optype_msgid,
2142 gfc_expr * op1, gfc_expr * op2)
2144 int op1_flag, op2_flag, d;
2145 mpz_t op1_size, op2_size;
2148 if (op1->rank == 0 || op2->rank == 0)
2151 if (op1->rank != op2->rank)
2153 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
2160 for (d = 0; d < op1->rank; d++)
2162 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2163 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2165 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2167 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2168 _(optype_msgid), &op1->where, d + 1,
2169 (int) mpz_get_si (op1_size),
2170 (int) mpz_get_si (op2_size));
2176 mpz_clear (op1_size);
2178 mpz_clear (op2_size);
2188 /* Given an assignable expression and an arbitrary expression, make
2189 sure that the assignment can take place. */
2192 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
2198 sym = lvalue->symtree->n.sym;
2200 /* Check INTENT(IN), unless the object itself is the component or
2201 sub-component of a pointer. */
2202 has_pointer = sym->attr.pointer;
2204 for (ref = lvalue->ref; ref; ref = ref->next)
2205 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2211 if (!has_pointer && sym->attr.intent == INTENT_IN)
2213 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2214 sym->name, &lvalue->where);
2218 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2219 variable local to a function subprogram. Its existence begins when
2220 execution of the function is initiated and ends when execution of the
2221 function is terminated.....
2222 Therefore, the left hand side is no longer a varaiable, when it is:*/
2223 if (sym->attr.flavor == FL_PROCEDURE
2224 && sym->attr.proc != PROC_ST_FUNCTION
2225 && !sym->attr.external)
2230 /* (i) Use associated; */
2231 if (sym->attr.use_assoc)
2234 /* (ii) The assignment is in the main program; or */
2235 if (gfc_current_ns->proc_name->attr.is_main_program)
2238 /* (iii) A module or internal procedure.... */
2239 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2240 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2241 && gfc_current_ns->parent
2242 && (!(gfc_current_ns->parent->proc_name->attr.function
2243 || gfc_current_ns->parent->proc_name->attr.subroutine)
2244 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2246 /* .... that is not a function.... */
2247 if (!gfc_current_ns->proc_name->attr.function)
2250 /* .... or is not an entry and has a different name. */
2251 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2257 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2262 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2264 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2265 lvalue->rank, rvalue->rank, &lvalue->where);
2269 if (lvalue->ts.type == BT_UNKNOWN)
2271 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2276 if (rvalue->expr_type == EXPR_NULL)
2278 gfc_error ("NULL appears on right-hand side in assignment at %L",
2283 if (sym->attr.cray_pointee
2284 && lvalue->ref != NULL
2285 && lvalue->ref->u.ar.type == AR_FULL
2286 && lvalue->ref->u.ar.as->cp_was_assumed)
2288 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
2289 " is illegal", &lvalue->where);
2293 /* This is possibly a typo: x = f() instead of x => f() */
2294 if (gfc_option.warn_surprising
2295 && rvalue->expr_type == EXPR_FUNCTION
2296 && rvalue->symtree->n.sym->attr.pointer)
2297 gfc_warning ("POINTER valued function appears on right-hand side of "
2298 "assignment at %L", &rvalue->where);
2300 /* Check size of array assignments. */
2301 if (lvalue->rank != 0 && rvalue->rank != 0
2302 && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
2305 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2310 /* Numeric can be converted to any other numeric. And Hollerith can be
2311 converted to any other type. */
2312 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2313 || rvalue->ts.type == BT_HOLLERITH)
2316 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2319 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2320 &rvalue->where, gfc_typename (&rvalue->ts),
2321 gfc_typename (&lvalue->ts));
2326 return gfc_convert_type (rvalue, &lvalue->ts, 1);
2330 /* Check that a pointer assignment is OK. We first check lvalue, and
2331 we only check rvalue if it's not an assignment to NULL() or a
2332 NULLIFY statement. */
2335 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
2337 symbol_attribute attr;
2340 int pointer, check_intent_in;
2342 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
2344 gfc_error ("Pointer assignment target is not a POINTER at %L",
2349 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
2350 && lvalue->symtree->n.sym->attr.use_assoc)
2352 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2353 "l-value since it is a procedure",
2354 lvalue->symtree->n.sym->name, &lvalue->where);
2359 /* Check INTENT(IN), unless the object itself is the component or
2360 sub-component of a pointer. */
2361 check_intent_in = 1;
2362 pointer = lvalue->symtree->n.sym->attr.pointer;
2364 for (ref = lvalue->ref; ref; ref = ref->next)
2367 check_intent_in = 0;
2369 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2373 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
2375 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2376 lvalue->symtree->n.sym->name, &lvalue->where);
2382 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
2386 is_pure = gfc_pure (NULL);
2388 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
2390 gfc_error ("Bad pointer object in PURE procedure at %L",
2395 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2396 kind, etc for lvalue and rvalue must match, and rvalue must be a
2397 pure variable if we're in a pure function. */
2398 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
2401 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
2403 gfc_error ("Different types in pointer assignment at %L",
2408 if (lvalue->ts.kind != rvalue->ts.kind)
2410 gfc_error ("Different kind type parameters in pointer "
2411 "assignment at %L", &lvalue->where);
2415 if (lvalue->rank != rvalue->rank)
2417 gfc_error ("Different ranks in pointer assignment at %L",
2422 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2423 if (rvalue->expr_type == EXPR_NULL)
2426 if (lvalue->ts.type == BT_CHARACTER
2427 && lvalue->ts.cl->length && rvalue->ts.cl->length
2428 && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2429 rvalue->ts.cl->length)) == 1)
2431 gfc_error ("Different character lengths in pointer "
2432 "assignment at %L", &lvalue->where);
2436 attr = gfc_expr_attr (rvalue);
2437 if (!attr.target && !attr.pointer)
2439 gfc_error ("Pointer assignment target is neither TARGET "
2440 "nor POINTER at %L", &rvalue->where);
2444 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2446 gfc_error ("Bad target in pointer assignment in PURE "
2447 "procedure at %L", &rvalue->where);
2450 if (gfc_has_vector_index (rvalue))
2452 gfc_error ("Pointer assignment with vector subscript "
2453 "on rhs at %L", &rvalue->where);
2457 if (attr.protected && attr.use_assoc)
2459 gfc_error ("Pointer assigment target has PROTECTED "
2460 "attribute at %L", &rvalue->where);
2468 /* Relative of gfc_check_assign() except that the lvalue is a single
2469 symbol. Used for initialization assignments. */
2472 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
2477 memset (&lvalue, '\0', sizeof (gfc_expr));
2479 lvalue.expr_type = EXPR_VARIABLE;
2480 lvalue.ts = sym->ts;
2482 lvalue.rank = sym->as->rank;
2483 lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
2484 lvalue.symtree->n.sym = sym;
2485 lvalue.where = sym->declared_at;
2487 if (sym->attr.pointer)
2488 r = gfc_check_pointer_assign (&lvalue, rvalue);
2490 r = gfc_check_assign (&lvalue, rvalue, 1);
2492 gfc_free (lvalue.symtree);
2498 /* Get an expression for a default initializer. */
2501 gfc_default_initializer (gfc_typespec *ts)
2503 gfc_constructor *tail;
2509 /* See if we have a default initializer. */
2510 for (c = ts->derived->components; c; c = c->next)
2512 if ((c->initializer || c->allocatable) && init == NULL)
2513 init = gfc_get_expr ();
2519 /* Build the constructor. */
2520 init->expr_type = EXPR_STRUCTURE;
2522 init->where = ts->derived->declared_at;
2524 for (c = ts->derived->components; c; c = c->next)
2527 init->value.constructor = tail = gfc_get_constructor ();
2530 tail->next = gfc_get_constructor ();
2535 tail->expr = gfc_copy_expr (c->initializer);
2539 tail->expr = gfc_get_expr ();
2540 tail->expr->expr_type = EXPR_NULL;
2541 tail->expr->ts = c->ts;
2548 /* Given a symbol, create an expression node with that symbol as a
2549 variable. If the symbol is array valued, setup a reference of the
2553 gfc_get_variable_expr (gfc_symtree * var)
2557 e = gfc_get_expr ();
2558 e->expr_type = EXPR_VARIABLE;
2560 e->ts = var->n.sym->ts;
2562 if (var->n.sym->as != NULL)
2564 e->rank = var->n.sym->as->rank;
2565 e->ref = gfc_get_ref ();
2566 e->ref->type = REF_ARRAY;
2567 e->ref->u.ar.type = AR_FULL;
2574 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2577 gfc_expr_set_symbols_referenced (gfc_expr * expr)
2579 gfc_actual_arglist *arg;
2586 switch (expr->expr_type)
2589 gfc_expr_set_symbols_referenced (expr->value.op.op1);
2590 gfc_expr_set_symbols_referenced (expr->value.op.op2);
2594 for (arg = expr->value.function.actual; arg; arg = arg->next)
2595 gfc_expr_set_symbols_referenced (arg->expr);
2599 gfc_set_sym_referenced (expr->symtree->n.sym);
2604 case EXPR_SUBSTRING:
2607 case EXPR_STRUCTURE:
2609 for (c = expr->value.constructor; c; c = c->next)
2610 gfc_expr_set_symbols_referenced (c->expr);
2618 for (ref = expr->ref; ref; ref = ref->next)
2622 for (i = 0; i < ref->u.ar.dimen; i++)
2624 gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2625 gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2626 gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2634 gfc_expr_set_symbols_referenced (ref->u.ss.start);
2635 gfc_expr_set_symbols_referenced (ref->u.ss.end);