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 end
[GFC_MAX_DIMENSIONS
];
1018 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1019 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1020 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1027 gfc_constructor
*cons
;
1028 gfc_constructor
*base
;
1038 base
= expr
->value
.constructor
;
1039 expr
->value
.constructor
= NULL
;
1041 rank
= ref
->u
.ar
.as
->rank
;
1043 if (expr
->shape
== NULL
)
1044 expr
->shape
= gfc_get_shape (rank
);
1046 mpz_init_set_ui (delta_mpz
, one
);
1047 mpz_init_set_ui (nelts
, one
);
1050 /* Do the initialization now, so that we can cleanup without
1051 keeping track of where we were. */
1052 for (d
= 0; d
< rank
; d
++)
1054 mpz_init (delta
[d
]);
1057 mpz_init (stride
[d
]);
1060 /* Build the counters to clock through the array reference. */
1061 for (d
= 0; d
< rank
; d
++)
1063 /* Make this stretch of code easier on the eye! */
1064 begin
= ref
->u
.ar
.start
[d
];
1065 finish
= ref
->u
.ar
.end
[d
];
1066 step
= ref
->u
.ar
.stride
[d
];
1067 lower
= ref
->u
.ar
.as
->lower
[d
];
1068 upper
= ref
->u
.ar
.as
->upper
[d
];
1070 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1071 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1072 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1078 /* Obtain the stride. */
1080 mpz_set (stride
[d
], step
->value
.integer
);
1082 mpz_set_ui (stride
[d
], one
);
1084 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1085 mpz_set_ui (stride
[d
], one
);
1087 /* Obtain the start value for the index. */
1088 if (begin
->value
.integer
)
1089 mpz_set (ctr
[d
], begin
->value
.integer
);
1092 if (mpz_cmp_si (stride
[d
], 0) < 0)
1093 mpz_set (ctr
[d
], upper
->value
.integer
);
1095 mpz_set (ctr
[d
], lower
->value
.integer
);
1098 /* Obtain the end value for the index. */
1100 mpz_set (end
[d
], finish
->value
.integer
);
1103 if (mpz_cmp_si (stride
[d
], 0) < 0)
1104 mpz_set (end
[d
], lower
->value
.integer
);
1106 mpz_set (end
[d
], upper
->value
.integer
);
1109 /* Separate 'if' because elements sometimes arrive with
1111 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1112 mpz_set (end
[d
], begin
->value
.integer
);
1114 /* Check the bounds. */
1115 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1116 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1117 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1118 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1120 gfc_error ("index in dimension %d is out of bounds "
1121 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1126 /* Calculate the number of elements and the shape. */
1127 mpz_abs (tmp_mpz
, stride
[d
]);
1128 mpz_div (tmp_mpz
, stride
[d
], tmp_mpz
);
1129 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1130 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1131 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1132 mpz_mul (nelts
, nelts
, tmp_mpz
);
1134 mpz_set (expr
->shape
[d
], tmp_mpz
);
1136 /* Calculate the 'stride' (=delta) for conversion of the
1137 counter values into the index along the constructor. */
1138 mpz_set (delta
[d
], delta_mpz
);
1139 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1140 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1141 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1149 /* Now clock through the array reference, calculating the index in
1150 the source constructor and transferring the elements to the new
1152 for (idx
= 0; idx
< (int)mpz_get_si (nelts
); idx
++)
1154 if (ref
->u
.ar
.offset
)
1155 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1157 mpz_init_set_ui (ptr
, 0);
1159 mpz_set_ui (stop
, one
);
1160 for (d
= 0; d
< rank
; d
++)
1162 mpz_set (tmp_mpz
, ctr
[d
]);
1163 mpz_sub_ui (tmp_mpz
, tmp_mpz
, one
);
1164 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1165 mpz_add (ptr
, ptr
, tmp_mpz
);
1167 mpz_mul (tmp_mpz
, stride
[d
], stop
);
1168 mpz_add (ctr
[d
], ctr
[d
], tmp_mpz
);
1170 mpz_set (tmp_mpz
, end
[d
]);
1171 if (mpz_cmp_ui (stride
[d
], 0) > 0 ?
1172 mpz_cmp (ctr
[d
], tmp_mpz
) > 0 :
1173 mpz_cmp (ctr
[d
], tmp_mpz
) < 0)
1174 mpz_set (ctr
[d
], ref
->u
.ar
.start
[d
]->value
.integer
);
1176 mpz_set_ui (stop
, 0);
1179 /* There must be a better way of dealing with negative strides
1180 than resetting the index and the constructor pointer! */
1181 if (mpz_cmp (ptr
, index
) < 0)
1183 mpz_set_ui (index
, 0);
1187 while (mpz_cmp (ptr
, index
) > 0)
1189 mpz_add_ui (index
, index
, one
);
1193 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1202 mpz_clear (delta_mpz
);
1203 mpz_clear (tmp_mpz
);
1205 for (d
= 0; d
< rank
; d
++)
1207 mpz_clear (delta
[d
]);
1210 mpz_clear (stride
[d
]);
1212 gfc_free_constructor (base
);
1216 /* Pull a substring out of an expression. */
1219 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1225 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1226 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1229 *newp
= gfc_copy_expr (p
);
1230 chr
= p
->value
.character
.string
;
1231 end
= (int)mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1232 start
= (int)mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1234 (*newp
)->value
.character
.length
= end
- start
+ 1;
1235 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1236 (*newp
)->value
.character
.length
);
1242 /* Simplify a subobject reference of a constructor. This occurs when
1243 parameter variable values are substituted. */
1246 simplify_const_ref (gfc_expr
* p
)
1248 gfc_constructor
*cons
;
1253 switch (p
->ref
->type
)
1256 switch (p
->ref
->u
.ar
.type
)
1259 if (find_array_element (p
->value
.constructor
,
1267 remove_subobject_ref (p
, cons
);
1271 if (find_array_section (p
, p
->ref
) == FAILURE
)
1273 p
->ref
->u
.ar
.type
= AR_FULL
;
1278 if (p
->ref
->next
!= NULL
1279 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1281 cons
= p
->value
.constructor
;
1282 for (; cons
; cons
= cons
->next
)
1284 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1285 simplify_const_ref (cons
->expr
);
1288 gfc_free_ref_list (p
->ref
);
1299 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1300 remove_subobject_ref (p
, cons
);
1304 if (find_substring_ref (p
, &newp
) == FAILURE
)
1307 gfc_replace_expr (p
, newp
);
1308 gfc_free_ref_list (p
->ref
);
1318 /* Simplify a chain of references. */
1321 simplify_ref_chain (gfc_ref
* ref
, int type
)
1325 for (; ref
; ref
= ref
->next
)
1330 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1332 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1335 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1338 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1346 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1348 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1360 /* Try to substitute the value of a parameter variable. */
1362 simplify_parameter_variable (gfc_expr
* p
, int type
)
1367 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1371 /* Do not copy subobject refs for constant. */
1372 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1373 e
->ref
= copy_ref (p
->ref
);
1374 t
= gfc_simplify_expr (e
, type
);
1376 /* Only use the simplification if it eliminated all subobject
1378 if (t
== SUCCESS
&& ! e
->ref
)
1379 gfc_replace_expr (p
, e
);
1386 /* Given an expression, simplify it by collapsing constant
1387 expressions. Most simplification takes place when the expression
1388 tree is being constructed. If an intrinsic function is simplified
1389 at some point, we get called again to collapse the result against
1392 We work by recursively simplifying expression nodes, simplifying
1393 intrinsic functions where possible, which can lead to further
1394 constant collapsing. If an operator has constant operand(s), we
1395 rip the expression apart, and rebuild it, hoping that it becomes
1398 The expression type is defined for:
1399 0 Basic expression parsing
1400 1 Simplifying array constructors -- will substitute
1402 Returns FAILURE on error, SUCCESS otherwise.
1403 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1406 gfc_simplify_expr (gfc_expr
* p
, int type
)
1408 gfc_actual_arglist
*ap
;
1413 switch (p
->expr_type
)
1420 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1421 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1424 if (p
->value
.function
.isym
!= NULL
1425 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1430 case EXPR_SUBSTRING
:
1431 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1434 if (gfc_is_constant_expr (p
))
1439 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1440 start
--; /* Convert from one-based to zero-based. */
1441 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1442 s
= gfc_getmem (end
- start
+ 1);
1443 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1444 s
[end
] = '\0'; /* TODO: C-style string for debugging. */
1445 gfc_free (p
->value
.character
.string
);
1446 p
->value
.character
.string
= s
;
1447 p
->value
.character
.length
= end
- start
;
1448 p
->ts
.cl
= gfc_get_charlen ();
1449 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1450 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1451 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1452 gfc_free_ref_list (p
->ref
);
1454 p
->expr_type
= EXPR_CONSTANT
;
1459 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1464 /* Only substitute array parameter variables if we are in an
1465 initialization expression, or we want a subsection. */
1466 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1467 && (gfc_init_expr
|| p
->ref
1468 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1470 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1477 gfc_simplify_iterator_var (p
);
1480 /* Simplify subcomponent references. */
1481 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1486 case EXPR_STRUCTURE
:
1488 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1491 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1494 if (p
->expr_type
== EXPR_ARRAY
1495 && p
->ref
&& p
->ref
->type
== REF_ARRAY
1496 && p
->ref
->u
.ar
.type
== AR_FULL
)
1497 gfc_expand_constructor (p
);
1499 if (simplify_const_ref (p
) == FAILURE
)
1509 /* Returns the type of an expression with the exception that iterator
1510 variables are automatically integers no matter what else they may
1517 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1524 /* Check an intrinsic arithmetic operation to see if it is consistent
1525 with some type of expression. */
1527 static try check_init_expr (gfc_expr
*);
1530 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1532 gfc_expr
*op1
= e
->value
.op
.op1
;
1533 gfc_expr
*op2
= e
->value
.op
.op2
;
1535 if ((*check_function
) (op1
) == FAILURE
)
1538 switch (e
->value
.op
.operator)
1540 case INTRINSIC_UPLUS
:
1541 case INTRINSIC_UMINUS
:
1542 if (!numeric_type (et0 (op1
)))
1552 if ((*check_function
) (op2
) == FAILURE
)
1555 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1556 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1558 gfc_error ("Numeric or CHARACTER operands are required in "
1559 "expression at %L", &e
->where
);
1564 case INTRINSIC_PLUS
:
1565 case INTRINSIC_MINUS
:
1566 case INTRINSIC_TIMES
:
1567 case INTRINSIC_DIVIDE
:
1568 case INTRINSIC_POWER
:
1569 if ((*check_function
) (op2
) == FAILURE
)
1572 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1575 if (e
->value
.op
.operator == INTRINSIC_POWER
1576 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1578 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1579 "expression", &op2
->where
);
1585 case INTRINSIC_CONCAT
:
1586 if ((*check_function
) (op2
) == FAILURE
)
1589 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1591 gfc_error ("Concatenation operator in expression at %L "
1592 "must have two CHARACTER operands", &op1
->where
);
1596 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1598 gfc_error ("Concat operator at %L must concatenate strings of the "
1599 "same kind", &e
->where
);
1606 if (et0 (op1
) != BT_LOGICAL
)
1608 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1609 "operand", &op1
->where
);
1618 case INTRINSIC_NEQV
:
1619 if ((*check_function
) (op2
) == FAILURE
)
1622 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1624 gfc_error ("LOGICAL operands are required in expression at %L",
1631 case INTRINSIC_PARENTHESES
:
1635 gfc_error ("Only intrinsic operators can be used in expression at %L",
1643 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1650 /* Certain inquiry functions are specifically allowed to have variable
1651 arguments, which is an exception to the normal requirement that an
1652 initialization function have initialization arguments. We head off
1653 this problem here. */
1656 check_inquiry (gfc_expr
* e
, int not_restricted
)
1660 /* FIXME: This should be moved into the intrinsic definitions,
1661 to eliminate this ugly hack. */
1662 static const char * const inquiry_function
[] = {
1663 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1664 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1665 "lbound", "ubound", NULL
1670 /* An undeclared parameter will get us here (PR25018). */
1671 if (e
->symtree
== NULL
)
1674 name
= e
->symtree
->n
.sym
->name
;
1676 for (i
= 0; inquiry_function
[i
]; i
++)
1677 if (strcmp (inquiry_function
[i
], name
) == 0)
1680 if (inquiry_function
[i
] == NULL
)
1683 e
= e
->value
.function
.actual
->expr
;
1685 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1688 /* At this point we have an inquiry function with a variable argument. The
1689 type of the variable might be undefined, but we need it now, because the
1690 arguments of these functions are allowed to be undefined. */
1692 if (e
->ts
.type
== BT_UNKNOWN
)
1694 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1695 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1699 e
->ts
= e
->symtree
->n
.sym
->ts
;
1702 /* Assumed character length will not reduce to a constant expression
1703 with LEN, as required by the standard. */
1704 if (i
== 4 && not_restricted
1705 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1706 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1707 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1708 "variable '%s' in constant expression at %L",
1709 e
->symtree
->n
.sym
->name
, &e
->where
);
1715 /* Verify that an expression is an initialization expression. A side
1716 effect is that the expression tree is reduced to a single constant
1717 node if all goes well. This would normally happen when the
1718 expression is constructed but function references are assumed to be
1719 intrinsics in the context of initialization expressions. If
1720 FAILURE is returned an error message has been generated. */
1723 check_init_expr (gfc_expr
* e
)
1725 gfc_actual_arglist
*ap
;
1732 switch (e
->expr_type
)
1735 t
= check_intrinsic_op (e
, check_init_expr
);
1737 t
= gfc_simplify_expr (e
, 0);
1744 if (check_inquiry (e
, 1) != SUCCESS
)
1747 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1748 if (check_init_expr (ap
->expr
) == FAILURE
)
1757 m
= gfc_intrinsic_func_interface (e
, 0);
1760 gfc_error ("Function '%s' in initialization expression at %L "
1761 "must be an intrinsic function",
1762 e
->symtree
->n
.sym
->name
, &e
->where
);
1773 if (gfc_check_iter_variable (e
) == SUCCESS
)
1776 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1778 t
= simplify_parameter_variable (e
, 0);
1782 gfc_error ("Parameter '%s' at %L has not been declared or is "
1783 "a variable, which does not reduce to a constant "
1784 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1793 case EXPR_SUBSTRING
:
1794 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1798 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1800 t
= gfc_simplify_expr (e
, 0);
1804 case EXPR_STRUCTURE
:
1805 t
= gfc_check_constructor (e
, check_init_expr
);
1809 t
= gfc_check_constructor (e
, check_init_expr
);
1813 t
= gfc_expand_constructor (e
);
1817 t
= gfc_check_constructor_type (e
);
1821 gfc_internal_error ("check_init_expr(): Unknown expression type");
1828 /* Match an initialization expression. We work by first matching an
1829 expression, then reducing it to a constant. */
1832 gfc_match_init_expr (gfc_expr
** result
)
1838 m
= gfc_match_expr (&expr
);
1843 t
= gfc_resolve_expr (expr
);
1845 t
= check_init_expr (expr
);
1850 gfc_free_expr (expr
);
1854 if (expr
->expr_type
== EXPR_ARRAY
1855 && (gfc_check_constructor_type (expr
) == FAILURE
1856 || gfc_expand_constructor (expr
) == FAILURE
))
1858 gfc_free_expr (expr
);
1862 /* Not all inquiry functions are simplified to constant expressions
1863 so it is necessary to call check_inquiry again. */
1864 if (!gfc_is_constant_expr (expr
)
1865 && check_inquiry (expr
, 1) == FAILURE
)
1867 gfc_error ("Initialization expression didn't reduce %C");
1878 static try check_restricted (gfc_expr
*);
1880 /* Given an actual argument list, test to see that each argument is a
1881 restricted expression and optionally if the expression type is
1882 integer or character. */
1885 restricted_args (gfc_actual_arglist
* a
)
1887 for (; a
; a
= a
->next
)
1889 if (check_restricted (a
->expr
) == FAILURE
)
1897 /************* Restricted/specification expressions *************/
1900 /* Make sure a non-intrinsic function is a specification function. */
1903 external_spec_function (gfc_expr
* e
)
1907 f
= e
->value
.function
.esym
;
1909 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1911 gfc_error ("Specification function '%s' at %L cannot be a statement "
1912 "function", f
->name
, &e
->where
);
1916 if (f
->attr
.proc
== PROC_INTERNAL
)
1918 gfc_error ("Specification function '%s' at %L cannot be an internal "
1919 "function", f
->name
, &e
->where
);
1923 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1925 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1930 if (f
->attr
.recursive
)
1932 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1933 f
->name
, &e
->where
);
1937 return restricted_args (e
->value
.function
.actual
);
1941 /* Check to see that a function reference to an intrinsic is a
1942 restricted expression. */
1945 restricted_intrinsic (gfc_expr
* e
)
1947 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1948 if (check_inquiry (e
, 0) == SUCCESS
)
1951 return restricted_args (e
->value
.function
.actual
);
1955 /* Verify that an expression is a restricted expression. Like its
1956 cousin check_init_expr(), an error message is generated if we
1960 check_restricted (gfc_expr
* e
)
1968 switch (e
->expr_type
)
1971 t
= check_intrinsic_op (e
, check_restricted
);
1973 t
= gfc_simplify_expr (e
, 0);
1978 t
= e
->value
.function
.esym
?
1979 external_spec_function (e
) : restricted_intrinsic (e
);
1984 sym
= e
->symtree
->n
.sym
;
1987 if (sym
->attr
.optional
)
1989 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1990 sym
->name
, &e
->where
);
1994 if (sym
->attr
.intent
== INTENT_OUT
)
1996 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1997 sym
->name
, &e
->where
);
2001 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
2002 in resolve.c(resolve_formal_arglist). This is done so that host associated
2003 dummy array indices are accepted (PR23446). */
2004 if (sym
->attr
.in_common
2005 || sym
->attr
.use_assoc
2007 || sym
->ns
!= gfc_current_ns
2008 || (sym
->ns
->proc_name
!= NULL
2009 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2010 || gfc_is_formal_arg ())
2016 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2017 sym
->name
, &e
->where
);
2026 case EXPR_SUBSTRING
:
2027 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2031 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2033 t
= gfc_simplify_expr (e
, 0);
2037 case EXPR_STRUCTURE
:
2038 t
= gfc_check_constructor (e
, check_restricted
);
2042 t
= gfc_check_constructor (e
, check_restricted
);
2046 gfc_internal_error ("check_restricted(): Unknown expression type");
2053 /* Check to see that an expression is a specification expression. If
2054 we return FAILURE, an error has been generated. */
2057 gfc_specification_expr (gfc_expr
* e
)
2062 if (e
->ts
.type
!= BT_INTEGER
)
2064 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2070 gfc_error ("Expression at %L must be scalar", &e
->where
);
2074 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2077 return check_restricted (e
);
2081 /************** Expression conformance checks. *************/
2083 /* Given two expressions, make sure that the arrays are conformable. */
2086 gfc_check_conformance (const char *optype_msgid
,
2087 gfc_expr
* op1
, gfc_expr
* op2
)
2089 int op1_flag
, op2_flag
, d
;
2090 mpz_t op1_size
, op2_size
;
2093 if (op1
->rank
== 0 || op2
->rank
== 0)
2096 if (op1
->rank
!= op2
->rank
)
2098 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2105 for (d
= 0; d
< op1
->rank
; d
++)
2107 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2108 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2110 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2112 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2113 _(optype_msgid
), &op1
->where
, d
+ 1,
2114 (int) mpz_get_si (op1_size
),
2115 (int) mpz_get_si (op2_size
));
2121 mpz_clear (op1_size
);
2123 mpz_clear (op2_size
);
2133 /* Given an assignable expression and an arbitrary expression, make
2134 sure that the assignment can take place. */
2137 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
2141 sym
= lvalue
->symtree
->n
.sym
;
2143 if (sym
->attr
.intent
== INTENT_IN
)
2145 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
2146 sym
->name
, &lvalue
->where
);
2150 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2151 variable local to a function subprogram. Its existence begins when
2152 execution of the function is initiated and ends when execution of the
2153 function is terminated.....
2154 Therefore, the left hand side is no longer a varaiable, when it is:*/
2155 if (sym
->attr
.flavor
== FL_PROCEDURE
2156 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2157 && !sym
->attr
.external
)
2162 /* (i) Use associated; */
2163 if (sym
->attr
.use_assoc
)
2166 /* (ii) The assignment is in the main program; or */
2167 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2170 /* (iii) A module or internal procedure.... */
2171 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2172 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2173 && gfc_current_ns
->parent
2174 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2175 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2176 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2178 /* .... that is not a function.... */
2179 if (!gfc_current_ns
->proc_name
->attr
.function
)
2182 /* .... or is not an entry and has a different name. */
2183 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2189 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2194 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2196 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2197 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2201 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2203 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2208 if (rvalue
->expr_type
== EXPR_NULL
)
2210 gfc_error ("NULL appears on right-hand side in assignment at %L",
2215 if (sym
->attr
.cray_pointee
2216 && lvalue
->ref
!= NULL
2217 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2218 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2220 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
2221 " is illegal.", &lvalue
->where
);
2225 /* This is possibly a typo: x = f() instead of x => f() */
2226 if (gfc_option
.warn_surprising
2227 && rvalue
->expr_type
== EXPR_FUNCTION
2228 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2229 gfc_warning ("POINTER valued function appears on right-hand side of "
2230 "assignment at %L", &rvalue
->where
);
2232 /* Check size of array assignments. */
2233 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2234 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2237 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2242 /* Numeric can be converted to any other numeric. And Hollerith can be
2243 converted to any other type. */
2244 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2245 || rvalue
->ts
.type
== BT_HOLLERITH
)
2248 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2251 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2252 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2253 gfc_typename (&lvalue
->ts
));
2258 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2262 /* Check that a pointer assignment is OK. We first check lvalue, and
2263 we only check rvalue if it's not an assignment to NULL() or a
2264 NULLIFY statement. */
2267 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
2269 symbol_attribute attr
;
2272 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2274 gfc_error ("Pointer assignment target is not a POINTER at %L",
2279 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2280 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2282 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2283 "l-value since it is a procedure",
2284 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2288 attr
= gfc_variable_attr (lvalue
, NULL
);
2291 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2295 is_pure
= gfc_pure (NULL
);
2297 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2299 gfc_error ("Bad pointer object in PURE procedure at %L",
2304 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2305 kind, etc for lvalue and rvalue must match, and rvalue must be a
2306 pure variable if we're in a pure function. */
2307 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2310 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2312 gfc_error ("Different types in pointer assignment at %L",
2317 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2319 gfc_error ("Different kind type parameters in pointer "
2320 "assignment at %L", &lvalue
->where
);
2324 if (lvalue
->rank
!= rvalue
->rank
)
2326 gfc_error ("Different ranks in pointer assignment at %L",
2331 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2332 if (rvalue
->expr_type
== EXPR_NULL
)
2335 if (lvalue
->ts
.type
== BT_CHARACTER
2336 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2337 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2338 rvalue
->ts
.cl
->length
)) == 1)
2340 gfc_error ("Different character lengths in pointer "
2341 "assignment at %L", &lvalue
->where
);
2345 attr
= gfc_expr_attr (rvalue
);
2346 if (!attr
.target
&& !attr
.pointer
)
2348 gfc_error ("Pointer assignment target is neither TARGET "
2349 "nor POINTER at %L", &rvalue
->where
);
2353 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2355 gfc_error ("Bad target in pointer assignment in PURE "
2356 "procedure at %L", &rvalue
->where
);
2359 if (gfc_has_vector_index (rvalue
))
2361 gfc_error ("Pointer assignment with vector subscript "
2362 "on rhs at %L", &rvalue
->where
);
2370 /* Relative of gfc_check_assign() except that the lvalue is a single
2371 symbol. Used for initialization assignments. */
2374 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2379 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2381 lvalue
.expr_type
= EXPR_VARIABLE
;
2382 lvalue
.ts
= sym
->ts
;
2384 lvalue
.rank
= sym
->as
->rank
;
2385 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2386 lvalue
.symtree
->n
.sym
= sym
;
2387 lvalue
.where
= sym
->declared_at
;
2389 if (sym
->attr
.pointer
)
2390 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2392 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2394 gfc_free (lvalue
.symtree
);
2400 /* Get an expression for a default initializer. */
2403 gfc_default_initializer (gfc_typespec
*ts
)
2405 gfc_constructor
*tail
;
2411 /* See if we have a default initializer. */
2412 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2414 if (c
->initializer
&& init
== NULL
)
2415 init
= gfc_get_expr ();
2421 /* Build the constructor. */
2422 init
->expr_type
= EXPR_STRUCTURE
;
2424 init
->where
= ts
->derived
->declared_at
;
2426 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2429 init
->value
.constructor
= tail
= gfc_get_constructor ();
2432 tail
->next
= gfc_get_constructor ();
2437 tail
->expr
= gfc_copy_expr (c
->initializer
);
2443 /* Given a symbol, create an expression node with that symbol as a
2444 variable. If the symbol is array valued, setup a reference of the
2448 gfc_get_variable_expr (gfc_symtree
* var
)
2452 e
= gfc_get_expr ();
2453 e
->expr_type
= EXPR_VARIABLE
;
2455 e
->ts
= var
->n
.sym
->ts
;
2457 if (var
->n
.sym
->as
!= NULL
)
2459 e
->rank
= var
->n
.sym
->as
->rank
;
2460 e
->ref
= gfc_get_ref ();
2461 e
->ref
->type
= REF_ARRAY
;
2462 e
->ref
->u
.ar
.type
= AR_FULL
;
2469 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2472 gfc_expr_set_symbols_referenced (gfc_expr
* expr
)
2474 gfc_actual_arglist
*arg
;
2481 switch (expr
->expr_type
)
2484 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2485 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2489 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2490 gfc_expr_set_symbols_referenced (arg
->expr
);
2494 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2499 case EXPR_SUBSTRING
:
2502 case EXPR_STRUCTURE
:
2504 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2505 gfc_expr_set_symbols_referenced (c
->expr
);
2513 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2517 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2519 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2520 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2521 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2529 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2530 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);