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
);
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
)
235 /* Graft the *src expression onto the *dest subexpression. */
238 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
248 /* Try to extract an integer constant from the passed expression node.
249 Returns an error message or NULL if the result is set. It is
250 tempting to generate an error and return SUCCESS or FAILURE, but
251 failure is OK for some callers. */
254 gfc_extract_int (gfc_expr
* expr
, int *result
)
257 if (expr
->expr_type
!= EXPR_CONSTANT
)
258 return _("Constant expression required at %C");
260 if (expr
->ts
.type
!= BT_INTEGER
)
261 return _("Integer expression required at %C");
263 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
264 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
266 return _("Integer value too large in expression at %C");
269 *result
= (int) mpz_get_si (expr
->value
.integer
);
275 /* Recursively copy a list of reference structures. */
278 copy_ref (gfc_ref
* src
)
286 dest
= gfc_get_ref ();
287 dest
->type
= src
->type
;
292 ar
= gfc_copy_array_ref (&src
->u
.ar
);
298 dest
->u
.c
= src
->u
.c
;
302 dest
->u
.ss
= src
->u
.ss
;
303 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
304 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
308 dest
->next
= copy_ref (src
->next
);
314 /* Detect whether an expression has any vector index array
318 gfc_has_vector_index (gfc_expr
*e
)
322 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
323 if (ref
->type
== REF_ARRAY
)
324 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
325 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
331 /* Copy a shape array. */
334 gfc_copy_shape (mpz_t
* shape
, int rank
)
342 new_shape
= gfc_get_shape (rank
);
344 for (n
= 0; n
< rank
; n
++)
345 mpz_init_set (new_shape
[n
], shape
[n
]);
351 /* Copy a shape array excluding dimension N, where N is an integer
352 constant expression. Dimensions are numbered in fortran style --
355 So, if the original shape array contains R elements
356 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
357 the result contains R-1 elements:
358 { s1 ... sN-1 sN+1 ... sR-1}
360 If anything goes wrong -- N is not a constant, its value is out
361 of range -- or anything else, just returns NULL.
365 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
367 mpz_t
*new_shape
, *s
;
373 || dim
->expr_type
!= EXPR_CONSTANT
374 || dim
->ts
.type
!= BT_INTEGER
)
377 n
= mpz_get_si (dim
->value
.integer
);
378 n
--; /* Convert to zero based index */
379 if (n
< 0 || n
>= rank
)
382 s
= new_shape
= gfc_get_shape (rank
-1);
384 for (i
= 0; i
< rank
; i
++)
388 mpz_init_set (*s
, shape
[i
]);
395 /* Given an expression pointer, return a copy of the expression. This
396 subroutine is recursive. */
399 gfc_copy_expr (gfc_expr
* p
)
410 switch (q
->expr_type
)
413 s
= gfc_getmem (p
->value
.character
.length
+ 1);
414 q
->value
.character
.string
= s
;
416 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
422 s
= gfc_getmem (p
->value
.character
.length
+ 1);
423 q
->value
.character
.string
= s
;
425 memcpy (s
, p
->value
.character
.string
,
426 p
->value
.character
.length
+ 1);
432 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
436 gfc_set_model_kind (q
->ts
.kind
);
437 mpfr_init (q
->value
.real
);
438 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
442 gfc_set_model_kind (q
->ts
.kind
);
443 mpfr_init (q
->value
.complex.r
);
444 mpfr_init (q
->value
.complex.i
);
445 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
446 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
451 s
= gfc_getmem (p
->value
.character
.length
+ 1);
452 q
->value
.character
.string
= s
;
454 memcpy (s
, p
->value
.character
.string
,
455 p
->value
.character
.length
+ 1);
460 break; /* Already done */
464 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
471 switch (q
->value
.op
.operator)
474 case INTRINSIC_UPLUS
:
475 case INTRINSIC_UMINUS
:
476 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
479 default: /* Binary operators */
480 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
481 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
488 q
->value
.function
.actual
=
489 gfc_copy_actual_arglist (p
->value
.function
.actual
);
494 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
502 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
504 q
->ref
= copy_ref (p
->ref
);
510 /* Return the maximum kind of two expressions. In general, higher
511 kind numbers mean more precision for numeric types. */
514 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
517 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
521 /* Returns nonzero if the type is numeric, zero otherwise. */
524 numeric_type (bt type
)
527 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
531 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
534 gfc_numeric_ts (gfc_typespec
* ts
)
537 return numeric_type (ts
->type
);
541 /* Returns an expression node that is an integer constant. */
550 p
->expr_type
= EXPR_CONSTANT
;
551 p
->ts
.type
= BT_INTEGER
;
552 p
->ts
.kind
= gfc_default_integer_kind
;
554 p
->where
= gfc_current_locus
;
555 mpz_init_set_si (p
->value
.integer
, i
);
561 /* Returns an expression node that is a logical constant. */
564 gfc_logical_expr (int i
, locus
* where
)
570 p
->expr_type
= EXPR_CONSTANT
;
571 p
->ts
.type
= BT_LOGICAL
;
572 p
->ts
.kind
= gfc_default_logical_kind
;
575 where
= &gfc_current_locus
;
577 p
->value
.logical
= i
;
583 /* Return an expression node with an optional argument list attached.
584 A variable number of gfc_expr pointers are strung together in an
585 argument list with a NULL pointer terminating the list. */
588 gfc_build_conversion (gfc_expr
* e
)
593 p
->expr_type
= EXPR_FUNCTION
;
595 p
->value
.function
.actual
= NULL
;
597 p
->value
.function
.actual
= gfc_get_actual_arglist ();
598 p
->value
.function
.actual
->expr
= e
;
604 /* Given an expression node with some sort of numeric binary
605 expression, insert type conversions required to make the operands
608 The exception is that the operands of an exponential don't have to
609 have the same type. If possible, the base is promoted to the type
610 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
611 1.0**2 stays as it is. */
614 gfc_type_convert_binary (gfc_expr
* e
)
618 op1
= e
->value
.op
.op1
;
619 op2
= e
->value
.op
.op2
;
621 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
623 gfc_clear_ts (&e
->ts
);
627 /* Kind conversions of same type. */
628 if (op1
->ts
.type
== op2
->ts
.type
)
631 if (op1
->ts
.kind
== op2
->ts
.kind
)
633 /* No type conversions. */
638 if (op1
->ts
.kind
> op2
->ts
.kind
)
639 gfc_convert_type (op2
, &op1
->ts
, 2);
641 gfc_convert_type (op1
, &op2
->ts
, 2);
647 /* Integer combined with real or complex. */
648 if (op2
->ts
.type
== BT_INTEGER
)
652 /* Special case for ** operator. */
653 if (e
->value
.op
.operator == INTRINSIC_POWER
)
656 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
660 if (op1
->ts
.type
== BT_INTEGER
)
663 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
667 /* Real combined with complex. */
668 e
->ts
.type
= BT_COMPLEX
;
669 if (op1
->ts
.kind
> op2
->ts
.kind
)
670 e
->ts
.kind
= op1
->ts
.kind
;
672 e
->ts
.kind
= op2
->ts
.kind
;
673 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
674 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
675 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
676 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
683 /* Function to determine if an expression is constant or not. This
684 function expects that the expression has already been simplified. */
687 gfc_is_constant_expr (gfc_expr
* e
)
690 gfc_actual_arglist
*arg
;
696 switch (e
->expr_type
)
699 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
700 && (e
->value
.op
.op2
== NULL
701 || gfc_is_constant_expr (e
->value
.op
.op2
)));
710 /* Call to intrinsic with at least one argument. */
712 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
714 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
716 if (!gfc_is_constant_expr (arg
->expr
))
730 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
731 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
736 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
737 if (!gfc_is_constant_expr (c
->expr
))
745 rv
= gfc_constant_ac (e
);
749 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
756 /* Try to collapse intrinsic expressions. */
759 simplify_intrinsic_op (gfc_expr
* p
, int type
)
761 gfc_expr
*op1
, *op2
, *result
;
763 if (p
->value
.op
.operator == INTRINSIC_USER
)
766 op1
= p
->value
.op
.op1
;
767 op2
= p
->value
.op
.op2
;
769 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
771 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
774 if (!gfc_is_constant_expr (op1
)
775 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
779 p
->value
.op
.op1
= NULL
;
780 p
->value
.op
.op2
= NULL
;
782 switch (p
->value
.op
.operator)
784 case INTRINSIC_UPLUS
:
785 case INTRINSIC_PARENTHESES
:
786 result
= gfc_uplus (op1
);
789 case INTRINSIC_UMINUS
:
790 result
= gfc_uminus (op1
);
794 result
= gfc_add (op1
, op2
);
797 case INTRINSIC_MINUS
:
798 result
= gfc_subtract (op1
, op2
);
801 case INTRINSIC_TIMES
:
802 result
= gfc_multiply (op1
, op2
);
805 case INTRINSIC_DIVIDE
:
806 result
= gfc_divide (op1
, op2
);
809 case INTRINSIC_POWER
:
810 result
= gfc_power (op1
, op2
);
813 case INTRINSIC_CONCAT
:
814 result
= gfc_concat (op1
, op2
);
818 result
= gfc_eq (op1
, op2
);
822 result
= gfc_ne (op1
, op2
);
826 result
= gfc_gt (op1
, op2
);
830 result
= gfc_ge (op1
, op2
);
834 result
= gfc_lt (op1
, op2
);
838 result
= gfc_le (op1
, op2
);
842 result
= gfc_not (op1
);
846 result
= gfc_and (op1
, op2
);
850 result
= gfc_or (op1
, op2
);
854 result
= gfc_eqv (op1
, op2
);
858 result
= gfc_neqv (op1
, op2
);
862 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
872 result
->rank
= p
->rank
;
873 result
->where
= p
->where
;
874 gfc_replace_expr (p
, result
);
880 /* Subroutine to simplify constructor expressions. Mutually recursive
881 with gfc_simplify_expr(). */
884 simplify_constructor (gfc_constructor
* c
, int type
)
887 for (; c
; c
= c
->next
)
890 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
891 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
892 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
895 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
903 /* Pull a single array element out of an array constructor. */
906 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
,
907 gfc_constructor
** rval
)
909 unsigned long nelemen
;
919 mpz_init_set_ui (offset
, 0);
921 for (i
= 0; i
< ar
->dimen
; i
++)
923 e
= gfc_copy_expr (ar
->start
[i
]);
924 if (e
->expr_type
!= EXPR_CONSTANT
)
930 /* Check the bounds. */
932 && (mpz_cmp (e
->value
.integer
,
933 ar
->as
->upper
[i
]->value
.integer
) > 0
934 || mpz_cmp (e
->value
.integer
,
935 ar
->as
->lower
[i
]->value
.integer
) < 0))
937 gfc_error ("index in dimension %d is out of bounds "
938 "at %L", i
+ 1, &ar
->c_where
[i
]);
944 mpz_sub (delta
, e
->value
.integer
,
945 ar
->as
->lower
[i
]->value
.integer
);
946 mpz_add (offset
, offset
, delta
);
951 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
972 /* Find a component of a structure constructor. */
974 static gfc_constructor
*
975 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
980 comp
= ref
->u
.c
.sym
->components
;
981 pick
= ref
->u
.c
.component
;
992 /* Replace an expression with the contents of a constructor, removing
993 the subobject reference in the process. */
996 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
1002 e
->ref
= p
->ref
->next
;
1003 p
->ref
->next
= NULL
;
1004 gfc_replace_expr (p
, e
);
1008 /* Pull an array section out of an array constructor. */
1011 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1016 long unsigned one
= 1;
1017 mpz_t start
[GFC_MAX_DIMENSIONS
];
1018 mpz_t end
[GFC_MAX_DIMENSIONS
];
1019 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1020 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1021 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1028 gfc_constructor
*cons
;
1029 gfc_constructor
*base
;
1039 base
= expr
->value
.constructor
;
1040 expr
->value
.constructor
= NULL
;
1042 rank
= ref
->u
.ar
.as
->rank
;
1044 if (expr
->shape
== NULL
)
1045 expr
->shape
= gfc_get_shape (rank
);
1047 mpz_init_set_ui (delta_mpz
, one
);
1048 mpz_init_set_ui (nelts
, one
);
1051 /* Do the initialization now, so that we can cleanup without
1052 keeping track of where we were. */
1053 for (d
= 0; d
< rank
; d
++)
1055 mpz_init (delta
[d
]);
1056 mpz_init (start
[d
]);
1059 mpz_init (stride
[d
]);
1062 /* Build the counters to clock through the array reference. */
1063 for (d
= 0; d
< rank
; d
++)
1065 /* Make this stretch of code easier on the eye! */
1066 begin
= ref
->u
.ar
.start
[d
];
1067 finish
= ref
->u
.ar
.end
[d
];
1068 step
= ref
->u
.ar
.stride
[d
];
1069 lower
= ref
->u
.ar
.as
->lower
[d
];
1070 upper
= ref
->u
.ar
.as
->upper
[d
];
1072 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1073 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1074 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1080 /* Obtain the stride. */
1082 mpz_set (stride
[d
], step
->value
.integer
);
1084 mpz_set_ui (stride
[d
], one
);
1086 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1087 mpz_set_ui (stride
[d
], one
);
1089 /* Obtain the start value for the index. */
1091 mpz_set (start
[d
], begin
->value
.integer
);
1093 mpz_set (start
[d
], lower
->value
.integer
);
1095 mpz_set (ctr
[d
], start
[d
]);
1097 /* Obtain the end value for the index. */
1099 mpz_set (end
[d
], finish
->value
.integer
);
1101 mpz_set (end
[d
], upper
->value
.integer
);
1103 /* Separate 'if' because elements sometimes arrive with
1105 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1106 mpz_set (end
[d
], begin
->value
.integer
);
1108 /* Check the bounds. */
1109 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1110 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1111 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1112 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1114 gfc_error ("index in dimension %d is out of bounds "
1115 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1120 /* Calculate the number of elements and the shape. */
1121 mpz_abs (tmp_mpz
, stride
[d
]);
1122 mpz_div (tmp_mpz
, stride
[d
], tmp_mpz
);
1123 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1124 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1125 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1126 mpz_mul (nelts
, nelts
, tmp_mpz
);
1128 mpz_set (expr
->shape
[d
], tmp_mpz
);
1130 /* Calculate the 'stride' (=delta) for conversion of the
1131 counter values into the index along the constructor. */
1132 mpz_set (delta
[d
], delta_mpz
);
1133 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1134 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1135 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1143 /* Now clock through the array reference, calculating the index in
1144 the source constructor and transferring the elements to the new
1146 for (idx
= 0; idx
< (int)mpz_get_si (nelts
); idx
++)
1148 if (ref
->u
.ar
.offset
)
1149 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1151 mpz_init_set_ui (ptr
, 0);
1153 mpz_set_ui (stop
, one
);
1154 for (d
= 0; d
< rank
; d
++)
1156 mpz_set (tmp_mpz
, ctr
[d
]);
1157 mpz_sub_ui (tmp_mpz
, tmp_mpz
, one
);
1158 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1159 mpz_add (ptr
, ptr
, tmp_mpz
);
1161 mpz_mul (tmp_mpz
, stride
[d
], stop
);
1162 mpz_add (ctr
[d
], ctr
[d
], tmp_mpz
);
1164 mpz_set (tmp_mpz
, end
[d
]);
1165 if (mpz_cmp_ui (stride
[d
], 0) > 0 ?
1166 mpz_cmp (ctr
[d
], tmp_mpz
) > 0 :
1167 mpz_cmp (ctr
[d
], tmp_mpz
) < 0)
1168 mpz_set (ctr
[d
], start
[d
]);
1170 mpz_set_ui (stop
, 0);
1173 /* There must be a better way of dealing with negative strides
1174 than resetting the index and the constructor pointer! */
1175 if (mpz_cmp (ptr
, index
) < 0)
1177 mpz_set_ui (index
, 0);
1181 while (mpz_cmp (ptr
, index
) > 0)
1183 mpz_add_ui (index
, index
, one
);
1187 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1196 mpz_clear (delta_mpz
);
1197 mpz_clear (tmp_mpz
);
1199 for (d
= 0; d
< rank
; d
++)
1201 mpz_clear (delta
[d
]);
1202 mpz_clear (start
[d
]);
1205 mpz_clear (stride
[d
]);
1207 gfc_free_constructor (base
);
1211 /* Pull a substring out of an expression. */
1214 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1220 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1221 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1224 *newp
= gfc_copy_expr (p
);
1225 chr
= p
->value
.character
.string
;
1226 end
= (int)mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1227 start
= (int)mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1229 (*newp
)->value
.character
.length
= end
- start
+ 1;
1230 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1231 (*newp
)->value
.character
.length
);
1237 /* Simplify a subobject reference of a constructor. This occurs when
1238 parameter variable values are substituted. */
1241 simplify_const_ref (gfc_expr
* p
)
1243 gfc_constructor
*cons
;
1248 switch (p
->ref
->type
)
1251 switch (p
->ref
->u
.ar
.type
)
1254 if (find_array_element (p
->value
.constructor
,
1262 remove_subobject_ref (p
, cons
);
1266 if (find_array_section (p
, p
->ref
) == FAILURE
)
1268 p
->ref
->u
.ar
.type
= AR_FULL
;
1273 if (p
->ref
->next
!= NULL
1274 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1276 cons
= p
->value
.constructor
;
1277 for (; cons
; cons
= cons
->next
)
1279 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1280 simplify_const_ref (cons
->expr
);
1283 gfc_free_ref_list (p
->ref
);
1294 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1295 remove_subobject_ref (p
, cons
);
1299 if (find_substring_ref (p
, &newp
) == FAILURE
)
1302 gfc_replace_expr (p
, newp
);
1303 gfc_free_ref_list (p
->ref
);
1313 /* Simplify a chain of references. */
1316 simplify_ref_chain (gfc_ref
* ref
, int type
)
1320 for (; ref
; ref
= ref
->next
)
1325 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1327 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1330 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1333 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1341 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1343 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1355 /* Try to substitute the value of a parameter variable. */
1357 simplify_parameter_variable (gfc_expr
* p
, int type
)
1362 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1368 /* Do not copy subobject refs for constant. */
1369 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1370 e
->ref
= copy_ref (p
->ref
);
1371 t
= gfc_simplify_expr (e
, type
);
1373 /* Only use the simplification if it eliminated all subobject
1375 if (t
== SUCCESS
&& ! e
->ref
)
1376 gfc_replace_expr (p
, e
);
1383 /* Given an expression, simplify it by collapsing constant
1384 expressions. Most simplification takes place when the expression
1385 tree is being constructed. If an intrinsic function is simplified
1386 at some point, we get called again to collapse the result against
1389 We work by recursively simplifying expression nodes, simplifying
1390 intrinsic functions where possible, which can lead to further
1391 constant collapsing. If an operator has constant operand(s), we
1392 rip the expression apart, and rebuild it, hoping that it becomes
1395 The expression type is defined for:
1396 0 Basic expression parsing
1397 1 Simplifying array constructors -- will substitute
1399 Returns FAILURE on error, SUCCESS otherwise.
1400 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1403 gfc_simplify_expr (gfc_expr
* p
, int type
)
1405 gfc_actual_arglist
*ap
;
1410 switch (p
->expr_type
)
1417 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1418 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1421 if (p
->value
.function
.isym
!= NULL
1422 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1427 case EXPR_SUBSTRING
:
1428 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1431 if (gfc_is_constant_expr (p
))
1436 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1437 start
--; /* Convert from one-based to zero-based. */
1438 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1439 s
= gfc_getmem (end
- start
+ 1);
1440 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1441 s
[end
] = '\0'; /* TODO: C-style string for debugging. */
1442 gfc_free (p
->value
.character
.string
);
1443 p
->value
.character
.string
= s
;
1444 p
->value
.character
.length
= end
- start
;
1445 p
->ts
.cl
= gfc_get_charlen ();
1446 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1447 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1448 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1449 gfc_free_ref_list (p
->ref
);
1451 p
->expr_type
= EXPR_CONSTANT
;
1456 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1461 /* Only substitute array parameter variables if we are in an
1462 initialization expression, or we want a subsection. */
1463 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1464 && (gfc_init_expr
|| p
->ref
1465 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1467 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1474 gfc_simplify_iterator_var (p
);
1477 /* Simplify subcomponent references. */
1478 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1483 case EXPR_STRUCTURE
:
1485 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1488 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1491 if (p
->expr_type
== EXPR_ARRAY
1492 && p
->ref
&& p
->ref
->type
== REF_ARRAY
1493 && p
->ref
->u
.ar
.type
== AR_FULL
)
1494 gfc_expand_constructor (p
);
1496 if (simplify_const_ref (p
) == FAILURE
)
1506 /* Returns the type of an expression with the exception that iterator
1507 variables are automatically integers no matter what else they may
1514 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1521 /* Check an intrinsic arithmetic operation to see if it is consistent
1522 with some type of expression. */
1524 static try check_init_expr (gfc_expr
*);
1527 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1529 gfc_expr
*op1
= e
->value
.op
.op1
;
1530 gfc_expr
*op2
= e
->value
.op
.op2
;
1532 if ((*check_function
) (op1
) == FAILURE
)
1535 switch (e
->value
.op
.operator)
1537 case INTRINSIC_UPLUS
:
1538 case INTRINSIC_UMINUS
:
1539 if (!numeric_type (et0 (op1
)))
1549 if ((*check_function
) (op2
) == FAILURE
)
1552 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1553 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1555 gfc_error ("Numeric or CHARACTER operands are required in "
1556 "expression at %L", &e
->where
);
1561 case INTRINSIC_PLUS
:
1562 case INTRINSIC_MINUS
:
1563 case INTRINSIC_TIMES
:
1564 case INTRINSIC_DIVIDE
:
1565 case INTRINSIC_POWER
:
1566 if ((*check_function
) (op2
) == FAILURE
)
1569 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1572 if (e
->value
.op
.operator == INTRINSIC_POWER
1573 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1575 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1576 "expression", &op2
->where
);
1582 case INTRINSIC_CONCAT
:
1583 if ((*check_function
) (op2
) == FAILURE
)
1586 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1588 gfc_error ("Concatenation operator in expression at %L "
1589 "must have two CHARACTER operands", &op1
->where
);
1593 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1595 gfc_error ("Concat operator at %L must concatenate strings of the "
1596 "same kind", &e
->where
);
1603 if (et0 (op1
) != BT_LOGICAL
)
1605 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1606 "operand", &op1
->where
);
1615 case INTRINSIC_NEQV
:
1616 if ((*check_function
) (op2
) == FAILURE
)
1619 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1621 gfc_error ("LOGICAL operands are required in expression at %L",
1628 case INTRINSIC_PARENTHESES
:
1632 gfc_error ("Only intrinsic operators can be used in expression at %L",
1640 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1647 /* Certain inquiry functions are specifically allowed to have variable
1648 arguments, which is an exception to the normal requirement that an
1649 initialization function have initialization arguments. We head off
1650 this problem here. */
1653 check_inquiry (gfc_expr
* e
, int not_restricted
)
1657 /* FIXME: This should be moved into the intrinsic definitions,
1658 to eliminate this ugly hack. */
1659 static const char * const inquiry_function
[] = {
1660 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1661 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1662 "lbound", "ubound", NULL
1667 /* An undeclared parameter will get us here (PR25018). */
1668 if (e
->symtree
== NULL
)
1671 name
= e
->symtree
->n
.sym
->name
;
1673 for (i
= 0; inquiry_function
[i
]; i
++)
1674 if (strcmp (inquiry_function
[i
], name
) == 0)
1677 if (inquiry_function
[i
] == NULL
)
1680 e
= e
->value
.function
.actual
->expr
;
1682 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1685 /* At this point we have an inquiry function with a variable argument. The
1686 type of the variable might be undefined, but we need it now, because the
1687 arguments of these functions are allowed to be undefined. */
1689 if (e
->ts
.type
== BT_UNKNOWN
)
1691 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1692 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1696 e
->ts
= e
->symtree
->n
.sym
->ts
;
1699 /* Assumed character length will not reduce to a constant expression
1700 with LEN, as required by the standard. */
1701 if (i
== 4 && not_restricted
1702 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1703 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1704 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1705 "variable '%s' in constant expression at %L",
1706 e
->symtree
->n
.sym
->name
, &e
->where
);
1712 /* Verify that an expression is an initialization expression. A side
1713 effect is that the expression tree is reduced to a single constant
1714 node if all goes well. This would normally happen when the
1715 expression is constructed but function references are assumed to be
1716 intrinsics in the context of initialization expressions. If
1717 FAILURE is returned an error message has been generated. */
1720 check_init_expr (gfc_expr
* e
)
1722 gfc_actual_arglist
*ap
;
1729 switch (e
->expr_type
)
1732 t
= check_intrinsic_op (e
, check_init_expr
);
1734 t
= gfc_simplify_expr (e
, 0);
1741 if (check_inquiry (e
, 1) != SUCCESS
)
1744 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1745 if (check_init_expr (ap
->expr
) == FAILURE
)
1754 m
= gfc_intrinsic_func_interface (e
, 0);
1757 gfc_error ("Function '%s' in initialization expression at %L "
1758 "must be an intrinsic function",
1759 e
->symtree
->n
.sym
->name
, &e
->where
);
1770 if (gfc_check_iter_variable (e
) == SUCCESS
)
1773 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1775 t
= simplify_parameter_variable (e
, 0);
1779 gfc_error ("Parameter '%s' at %L has not been declared or is "
1780 "a variable, which does not reduce to a constant "
1781 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1790 case EXPR_SUBSTRING
:
1791 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1795 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1797 t
= gfc_simplify_expr (e
, 0);
1801 case EXPR_STRUCTURE
:
1802 t
= gfc_check_constructor (e
, check_init_expr
);
1806 t
= gfc_check_constructor (e
, check_init_expr
);
1810 t
= gfc_expand_constructor (e
);
1814 t
= gfc_check_constructor_type (e
);
1818 gfc_internal_error ("check_init_expr(): Unknown expression type");
1825 /* Match an initialization expression. We work by first matching an
1826 expression, then reducing it to a constant. */
1829 gfc_match_init_expr (gfc_expr
** result
)
1835 m
= gfc_match_expr (&expr
);
1840 t
= gfc_resolve_expr (expr
);
1842 t
= check_init_expr (expr
);
1847 gfc_free_expr (expr
);
1851 if (expr
->expr_type
== EXPR_ARRAY
1852 && (gfc_check_constructor_type (expr
) == FAILURE
1853 || gfc_expand_constructor (expr
) == FAILURE
))
1855 gfc_free_expr (expr
);
1859 /* Not all inquiry functions are simplified to constant expressions
1860 so it is necessary to call check_inquiry again. */
1861 if (!gfc_is_constant_expr (expr
)
1862 && check_inquiry (expr
, 1) == FAILURE
)
1864 gfc_error ("Initialization expression didn't reduce %C");
1875 static try check_restricted (gfc_expr
*);
1877 /* Given an actual argument list, test to see that each argument is a
1878 restricted expression and optionally if the expression type is
1879 integer or character. */
1882 restricted_args (gfc_actual_arglist
* a
)
1884 for (; a
; a
= a
->next
)
1886 if (check_restricted (a
->expr
) == FAILURE
)
1894 /************* Restricted/specification expressions *************/
1897 /* Make sure a non-intrinsic function is a specification function. */
1900 external_spec_function (gfc_expr
* e
)
1904 f
= e
->value
.function
.esym
;
1906 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1908 gfc_error ("Specification function '%s' at %L cannot be a statement "
1909 "function", f
->name
, &e
->where
);
1913 if (f
->attr
.proc
== PROC_INTERNAL
)
1915 gfc_error ("Specification function '%s' at %L cannot be an internal "
1916 "function", f
->name
, &e
->where
);
1920 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1922 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1927 if (f
->attr
.recursive
)
1929 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1930 f
->name
, &e
->where
);
1934 return restricted_args (e
->value
.function
.actual
);
1938 /* Check to see that a function reference to an intrinsic is a
1939 restricted expression. */
1942 restricted_intrinsic (gfc_expr
* e
)
1944 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1945 if (check_inquiry (e
, 0) == SUCCESS
)
1948 return restricted_args (e
->value
.function
.actual
);
1952 /* Verify that an expression is a restricted expression. Like its
1953 cousin check_init_expr(), an error message is generated if we
1957 check_restricted (gfc_expr
* e
)
1965 switch (e
->expr_type
)
1968 t
= check_intrinsic_op (e
, check_restricted
);
1970 t
= gfc_simplify_expr (e
, 0);
1975 t
= e
->value
.function
.esym
?
1976 external_spec_function (e
) : restricted_intrinsic (e
);
1981 sym
= e
->symtree
->n
.sym
;
1984 if (sym
->attr
.optional
)
1986 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1987 sym
->name
, &e
->where
);
1991 if (sym
->attr
.intent
== INTENT_OUT
)
1993 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1994 sym
->name
, &e
->where
);
1998 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1999 in resolve.c(resolve_formal_arglist). This is done so that host associated
2000 dummy array indices are accepted (PR23446). */
2001 if (sym
->attr
.in_common
2002 || sym
->attr
.use_assoc
2004 || sym
->ns
!= gfc_current_ns
2005 || (sym
->ns
->proc_name
!= NULL
2006 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2007 || gfc_is_formal_arg ())
2013 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2014 sym
->name
, &e
->where
);
2023 case EXPR_SUBSTRING
:
2024 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2028 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2030 t
= gfc_simplify_expr (e
, 0);
2034 case EXPR_STRUCTURE
:
2035 t
= gfc_check_constructor (e
, check_restricted
);
2039 t
= gfc_check_constructor (e
, check_restricted
);
2043 gfc_internal_error ("check_restricted(): Unknown expression type");
2050 /* Check to see that an expression is a specification expression. If
2051 we return FAILURE, an error has been generated. */
2054 gfc_specification_expr (gfc_expr
* e
)
2059 if (e
->ts
.type
!= BT_INTEGER
)
2061 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2067 gfc_error ("Expression at %L must be scalar", &e
->where
);
2071 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2074 return check_restricted (e
);
2078 /************** Expression conformance checks. *************/
2080 /* Given two expressions, make sure that the arrays are conformable. */
2083 gfc_check_conformance (const char *optype_msgid
,
2084 gfc_expr
* op1
, gfc_expr
* op2
)
2086 int op1_flag
, op2_flag
, d
;
2087 mpz_t op1_size
, op2_size
;
2090 if (op1
->rank
== 0 || op2
->rank
== 0)
2093 if (op1
->rank
!= op2
->rank
)
2095 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2102 for (d
= 0; d
< op1
->rank
; d
++)
2104 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2105 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2107 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2109 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2110 _(optype_msgid
), &op1
->where
, d
+ 1,
2111 (int) mpz_get_si (op1_size
),
2112 (int) mpz_get_si (op2_size
));
2118 mpz_clear (op1_size
);
2120 mpz_clear (op2_size
);
2130 /* Given an assignable expression and an arbitrary expression, make
2131 sure that the assignment can take place. */
2134 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
2138 sym
= lvalue
->symtree
->n
.sym
;
2140 if (sym
->attr
.intent
== INTENT_IN
)
2142 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
2143 sym
->name
, &lvalue
->where
);
2147 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2148 variable local to a function subprogram. Its existence begins when
2149 execution of the function is initiated and ends when execution of the
2150 function is terminated.....
2151 Therefore, the left hand side is no longer a varaiable, when it is:*/
2152 if (sym
->attr
.flavor
== FL_PROCEDURE
2153 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2154 && !sym
->attr
.external
)
2159 /* (i) Use associated; */
2160 if (sym
->attr
.use_assoc
)
2163 /* (ii) The assignment is in the main program; or */
2164 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2167 /* (iii) A module or internal procedure.... */
2168 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2169 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2170 && gfc_current_ns
->parent
2171 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2172 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2173 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2175 /* .... that is not a function.... */
2176 if (!gfc_current_ns
->proc_name
->attr
.function
)
2179 /* .... or is not an entry and has a different name. */
2180 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2186 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2191 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2193 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2194 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2198 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2200 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2205 if (rvalue
->expr_type
== EXPR_NULL
)
2207 gfc_error ("NULL appears on right-hand side in assignment at %L",
2212 if (sym
->attr
.cray_pointee
2213 && lvalue
->ref
!= NULL
2214 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2215 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2217 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
2218 " is illegal.", &lvalue
->where
);
2222 /* This is possibly a typo: x = f() instead of x => f() */
2223 if (gfc_option
.warn_surprising
2224 && rvalue
->expr_type
== EXPR_FUNCTION
2225 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2226 gfc_warning ("POINTER valued function appears on right-hand side of "
2227 "assignment at %L", &rvalue
->where
);
2229 /* Check size of array assignments. */
2230 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2231 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2234 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2239 /* Numeric can be converted to any other numeric. And Hollerith can be
2240 converted to any other type. */
2241 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2242 || rvalue
->ts
.type
== BT_HOLLERITH
)
2245 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2248 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2249 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2250 gfc_typename (&lvalue
->ts
));
2255 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2259 /* Check that a pointer assignment is OK. We first check lvalue, and
2260 we only check rvalue if it's not an assignment to NULL() or a
2261 NULLIFY statement. */
2264 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
2266 symbol_attribute attr
;
2269 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2271 gfc_error ("Pointer assignment target is not a POINTER at %L",
2276 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2277 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2279 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2280 "l-value since it is a procedure",
2281 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2285 attr
= gfc_variable_attr (lvalue
, NULL
);
2288 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2292 is_pure
= gfc_pure (NULL
);
2294 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2296 gfc_error ("Bad pointer object in PURE procedure at %L",
2301 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2302 kind, etc for lvalue and rvalue must match, and rvalue must be a
2303 pure variable if we're in a pure function. */
2304 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2307 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2309 gfc_error ("Different types in pointer assignment at %L",
2314 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2316 gfc_error ("Different kind type parameters in pointer "
2317 "assignment at %L", &lvalue
->where
);
2321 if (lvalue
->rank
!= rvalue
->rank
)
2323 gfc_error ("Different ranks in pointer assignment at %L",
2328 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2329 if (rvalue
->expr_type
== EXPR_NULL
)
2332 if (lvalue
->ts
.type
== BT_CHARACTER
2333 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2334 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2335 rvalue
->ts
.cl
->length
)) == 1)
2337 gfc_error ("Different character lengths in pointer "
2338 "assignment at %L", &lvalue
->where
);
2342 attr
= gfc_expr_attr (rvalue
);
2343 if (!attr
.target
&& !attr
.pointer
)
2345 gfc_error ("Pointer assignment target is neither TARGET "
2346 "nor POINTER at %L", &rvalue
->where
);
2350 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2352 gfc_error ("Bad target in pointer assignment in PURE "
2353 "procedure at %L", &rvalue
->where
);
2356 if (gfc_has_vector_index (rvalue
))
2358 gfc_error ("Pointer assignment with vector subscript "
2359 "on rhs at %L", &rvalue
->where
);
2367 /* Relative of gfc_check_assign() except that the lvalue is a single
2368 symbol. Used for initialization assignments. */
2371 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2376 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2378 lvalue
.expr_type
= EXPR_VARIABLE
;
2379 lvalue
.ts
= sym
->ts
;
2381 lvalue
.rank
= sym
->as
->rank
;
2382 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2383 lvalue
.symtree
->n
.sym
= sym
;
2384 lvalue
.where
= sym
->declared_at
;
2386 if (sym
->attr
.pointer
)
2387 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2389 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2391 gfc_free (lvalue
.symtree
);
2397 /* Get an expression for a default initializer. */
2400 gfc_default_initializer (gfc_typespec
*ts
)
2402 gfc_constructor
*tail
;
2408 /* See if we have a default initializer. */
2409 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2411 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2412 init
= gfc_get_expr ();
2418 /* Build the constructor. */
2419 init
->expr_type
= EXPR_STRUCTURE
;
2421 init
->where
= ts
->derived
->declared_at
;
2423 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2426 init
->value
.constructor
= tail
= gfc_get_constructor ();
2429 tail
->next
= gfc_get_constructor ();
2434 tail
->expr
= gfc_copy_expr (c
->initializer
);
2438 tail
->expr
= gfc_get_expr ();
2439 tail
->expr
->expr_type
= EXPR_NULL
;
2440 tail
->expr
->ts
= c
->ts
;
2447 /* Given a symbol, create an expression node with that symbol as a
2448 variable. If the symbol is array valued, setup a reference of the
2452 gfc_get_variable_expr (gfc_symtree
* var
)
2456 e
= gfc_get_expr ();
2457 e
->expr_type
= EXPR_VARIABLE
;
2459 e
->ts
= var
->n
.sym
->ts
;
2461 if (var
->n
.sym
->as
!= NULL
)
2463 e
->rank
= var
->n
.sym
->as
->rank
;
2464 e
->ref
= gfc_get_ref ();
2465 e
->ref
->type
= REF_ARRAY
;
2466 e
->ref
->u
.ar
.type
= AR_FULL
;
2473 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2476 gfc_expr_set_symbols_referenced (gfc_expr
* expr
)
2478 gfc_actual_arglist
*arg
;
2485 switch (expr
->expr_type
)
2488 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2489 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2493 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2494 gfc_expr_set_symbols_referenced (arg
->expr
);
2498 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2503 case EXPR_SUBSTRING
:
2506 case EXPR_STRUCTURE
:
2508 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2509 gfc_expr_set_symbols_referenced (c
->expr
);
2517 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2521 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2523 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2524 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2525 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2533 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2534 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);