1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
145 gfc_free (e
->value
.character
.string
);
152 mpz_clear (e
->value
.integer
);
156 mpfr_clear (e
->value
.real
);
161 gfc_free (e
->value
.character
.string
);
165 mpfr_clear (e
->value
.complex.r
);
166 mpfr_clear (e
->value
.complex.i
);
176 if (e
->value
.op
.op1
!= NULL
)
177 gfc_free_expr (e
->value
.op
.op1
);
178 if (e
->value
.op
.op2
!= NULL
)
179 gfc_free_expr (e
->value
.op
.op2
);
183 gfc_free_actual_arglist (e
->value
.function
.actual
);
191 gfc_free_constructor (e
->value
.constructor
);
195 gfc_free (e
->value
.character
.string
);
202 gfc_internal_error ("free_expr0(): Bad expr type");
205 /* Free a shape array. */
206 if (e
->shape
!= NULL
)
208 for (n
= 0; n
< e
->rank
; n
++)
209 mpz_clear (e
->shape
[n
]);
214 gfc_free_ref_list (e
->ref
);
216 memset (e
, '\0', sizeof (gfc_expr
));
220 /* Free an expression node and everything beneath it. */
223 gfc_free_expr (gfc_expr
*e
)
227 if (e
->con_by_offset
)
228 splay_tree_delete (e
->con_by_offset
);
234 /* Graft the *src expression onto the *dest subexpression. */
237 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
245 /* Try to extract an integer constant from the passed expression node.
246 Returns an error message or NULL if the result is set. It is
247 tempting to generate an error and return SUCCESS or FAILURE, but
248 failure is OK for some callers. */
251 gfc_extract_int (gfc_expr
*expr
, int *result
)
253 if (expr
->expr_type
!= EXPR_CONSTANT
)
254 return _("Constant expression required at %C");
256 if (expr
->ts
.type
!= BT_INTEGER
)
257 return _("Integer expression required at %C");
259 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
260 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
262 return _("Integer value too large in expression at %C");
265 *result
= (int) mpz_get_si (expr
->value
.integer
);
271 /* Recursively copy a list of reference structures. */
274 copy_ref (gfc_ref
*src
)
282 dest
= gfc_get_ref ();
283 dest
->type
= src
->type
;
288 ar
= gfc_copy_array_ref (&src
->u
.ar
);
294 dest
->u
.c
= src
->u
.c
;
298 dest
->u
.ss
= src
->u
.ss
;
299 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
300 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
304 dest
->next
= copy_ref (src
->next
);
310 /* Detect whether an expression has any vector index array references. */
313 gfc_has_vector_index (gfc_expr
*e
)
317 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
318 if (ref
->type
== REF_ARRAY
)
319 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
320 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
326 /* Copy a shape array. */
329 gfc_copy_shape (mpz_t
*shape
, int rank
)
337 new_shape
= gfc_get_shape (rank
);
339 for (n
= 0; n
< rank
; n
++)
340 mpz_init_set (new_shape
[n
], shape
[n
]);
346 /* Copy a shape array excluding dimension N, where N is an integer
347 constant expression. Dimensions are numbered in fortran style --
350 So, if the original shape array contains R elements
351 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
352 the result contains R-1 elements:
353 { s1 ... sN-1 sN+1 ... sR-1}
355 If anything goes wrong -- N is not a constant, its value is out
356 of range -- or anything else, just returns NULL.
360 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
362 mpz_t
*new_shape
, *s
;
368 || dim
->expr_type
!= EXPR_CONSTANT
369 || dim
->ts
.type
!= BT_INTEGER
)
372 n
= mpz_get_si (dim
->value
.integer
);
373 n
--; /* Convert to zero based index */
374 if (n
< 0 || n
>= rank
)
377 s
= new_shape
= gfc_get_shape (rank
- 1);
379 for (i
= 0; i
< rank
; i
++)
383 mpz_init_set (*s
, shape
[i
]);
391 /* Given an expression pointer, return a copy of the expression. This
392 subroutine is recursive. */
395 gfc_copy_expr (gfc_expr
*p
)
406 switch (q
->expr_type
)
409 s
= gfc_getmem (p
->value
.character
.length
+ 1);
410 q
->value
.character
.string
= s
;
412 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
418 s
= gfc_getmem (p
->value
.character
.length
+ 1);
419 q
->value
.character
.string
= s
;
421 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
446 s
= gfc_getmem (p
->value
.character
.length
+ 1);
447 q
->value
.character
.string
= s
;
449 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
454 break; /* Already done */
458 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
465 switch (q
->value
.op
.operator)
468 case INTRINSIC_UPLUS
:
469 case INTRINSIC_UMINUS
:
470 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
473 default: /* Binary operators */
474 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
475 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
482 q
->value
.function
.actual
=
483 gfc_copy_actual_arglist (p
->value
.function
.actual
);
488 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
496 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
498 q
->ref
= copy_ref (p
->ref
);
504 /* Return the maximum kind of two expressions. In general, higher
505 kind numbers mean more precision for numeric types. */
508 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
510 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
514 /* Returns nonzero if the type is numeric, zero otherwise. */
517 numeric_type (bt type
)
519 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
523 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
526 gfc_numeric_ts (gfc_typespec
*ts
)
528 return numeric_type (ts
->type
);
532 /* Returns an expression node that is an integer constant. */
541 p
->expr_type
= EXPR_CONSTANT
;
542 p
->ts
.type
= BT_INTEGER
;
543 p
->ts
.kind
= gfc_default_integer_kind
;
545 p
->where
= gfc_current_locus
;
546 mpz_init_set_si (p
->value
.integer
, i
);
552 /* Returns an expression node that is a logical constant. */
555 gfc_logical_expr (int i
, locus
*where
)
561 p
->expr_type
= EXPR_CONSTANT
;
562 p
->ts
.type
= BT_LOGICAL
;
563 p
->ts
.kind
= gfc_default_logical_kind
;
566 where
= &gfc_current_locus
;
568 p
->value
.logical
= i
;
574 /* Return an expression node with an optional argument list attached.
575 A variable number of gfc_expr pointers are strung together in an
576 argument list with a NULL pointer terminating the list. */
579 gfc_build_conversion (gfc_expr
*e
)
584 p
->expr_type
= EXPR_FUNCTION
;
586 p
->value
.function
.actual
= NULL
;
588 p
->value
.function
.actual
= gfc_get_actual_arglist ();
589 p
->value
.function
.actual
->expr
= e
;
595 /* Given an expression node with some sort of numeric binary
596 expression, insert type conversions required to make the operands
599 The exception is that the operands of an exponential don't have to
600 have the same type. If possible, the base is promoted to the type
601 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
602 1.0**2 stays as it is. */
605 gfc_type_convert_binary (gfc_expr
*e
)
609 op1
= e
->value
.op
.op1
;
610 op2
= e
->value
.op
.op2
;
612 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
614 gfc_clear_ts (&e
->ts
);
618 /* Kind conversions of same type. */
619 if (op1
->ts
.type
== op2
->ts
.type
)
621 if (op1
->ts
.kind
== op2
->ts
.kind
)
623 /* No type conversions. */
628 if (op1
->ts
.kind
> op2
->ts
.kind
)
629 gfc_convert_type (op2
, &op1
->ts
, 2);
631 gfc_convert_type (op1
, &op2
->ts
, 2);
637 /* Integer combined with real or complex. */
638 if (op2
->ts
.type
== BT_INTEGER
)
642 /* Special case for ** operator. */
643 if (e
->value
.op
.operator == INTRINSIC_POWER
)
646 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
650 if (op1
->ts
.type
== BT_INTEGER
)
653 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
657 /* Real combined with complex. */
658 e
->ts
.type
= BT_COMPLEX
;
659 if (op1
->ts
.kind
> op2
->ts
.kind
)
660 e
->ts
.kind
= op1
->ts
.kind
;
662 e
->ts
.kind
= op2
->ts
.kind
;
663 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
664 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
665 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
666 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
673 /* Function to determine if an expression is constant or not. This
674 function expects that the expression has already been simplified. */
677 gfc_is_constant_expr (gfc_expr
*e
)
680 gfc_actual_arglist
*arg
;
686 switch (e
->expr_type
)
689 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
690 && (e
->value
.op
.op2
== NULL
691 || gfc_is_constant_expr (e
->value
.op
.op2
)));
700 /* Call to intrinsic with at least one argument. */
702 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
704 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
706 if (!gfc_is_constant_expr (arg
->expr
))
720 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
721 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
726 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
727 if (!gfc_is_constant_expr (c
->expr
))
735 rv
= gfc_constant_ac (e
);
739 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
746 /* Try to collapse intrinsic expressions. */
749 simplify_intrinsic_op (gfc_expr
*p
, int type
)
751 gfc_expr
*op1
, *op2
, *result
;
753 if (p
->value
.op
.operator == INTRINSIC_USER
)
756 op1
= p
->value
.op
.op1
;
757 op2
= p
->value
.op
.op2
;
759 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
761 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
764 if (!gfc_is_constant_expr (op1
)
765 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
769 p
->value
.op
.op1
= NULL
;
770 p
->value
.op
.op2
= NULL
;
772 switch (p
->value
.op
.operator)
774 case INTRINSIC_UPLUS
:
775 case INTRINSIC_PARENTHESES
:
776 result
= gfc_uplus (op1
);
779 case INTRINSIC_UMINUS
:
780 result
= gfc_uminus (op1
);
784 result
= gfc_add (op1
, op2
);
787 case INTRINSIC_MINUS
:
788 result
= gfc_subtract (op1
, op2
);
791 case INTRINSIC_TIMES
:
792 result
= gfc_multiply (op1
, op2
);
795 case INTRINSIC_DIVIDE
:
796 result
= gfc_divide (op1
, op2
);
799 case INTRINSIC_POWER
:
800 result
= gfc_power (op1
, op2
);
803 case INTRINSIC_CONCAT
:
804 result
= gfc_concat (op1
, op2
);
808 result
= gfc_eq (op1
, op2
);
812 result
= gfc_ne (op1
, op2
);
816 result
= gfc_gt (op1
, op2
);
820 result
= gfc_ge (op1
, op2
);
824 result
= gfc_lt (op1
, op2
);
828 result
= gfc_le (op1
, op2
);
832 result
= gfc_not (op1
);
836 result
= gfc_and (op1
, op2
);
840 result
= gfc_or (op1
, op2
);
844 result
= gfc_eqv (op1
, op2
);
848 result
= gfc_neqv (op1
, op2
);
852 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
862 result
->rank
= p
->rank
;
863 result
->where
= p
->where
;
864 gfc_replace_expr (p
, result
);
870 /* Subroutine to simplify constructor expressions. Mutually recursive
871 with gfc_simplify_expr(). */
874 simplify_constructor (gfc_constructor
*c
, int type
)
876 for (; c
; c
= c
->next
)
879 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
880 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
881 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
884 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
892 /* Pull a single array element out of an array constructor. */
895 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
896 gfc_constructor
**rval
)
898 unsigned long nelemen
;
910 mpz_init_set_ui (offset
, 0);
913 mpz_init_set_ui (span
, 1);
914 for (i
= 0; i
< ar
->dimen
; i
++)
916 e
= gfc_copy_expr (ar
->start
[i
]);
917 if (e
->expr_type
!= EXPR_CONSTANT
)
923 /* Check the bounds. */
925 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
926 || mpz_cmp (e
->value
.integer
,
927 ar
->as
->lower
[i
]->value
.integer
) < 0))
929 gfc_error ("index in dimension %d is out of bounds "
930 "at %L", i
+ 1, &ar
->c_where
[i
]);
936 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
937 mpz_mul (delta
, delta
, span
);
938 mpz_add (offset
, offset
, delta
);
941 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
942 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
943 mpz_mul (span
, span
, tmp
);
948 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
971 /* Find a component of a structure constructor. */
973 static gfc_constructor
*
974 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
979 comp
= ref
->u
.c
.sym
->components
;
980 pick
= ref
->u
.c
.component
;
991 /* Replace an expression with the contents of a constructor, removing
992 the subobject reference in the process. */
995 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1001 e
->ref
= p
->ref
->next
;
1002 p
->ref
->next
= NULL
;
1003 gfc_replace_expr (p
, e
);
1007 /* Pull an array section out of an array constructor. */
1010 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1016 long unsigned one
= 1;
1018 mpz_t start
[GFC_MAX_DIMENSIONS
];
1019 mpz_t end
[GFC_MAX_DIMENSIONS
];
1020 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1021 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1022 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1028 gfc_constructor
*cons
;
1029 gfc_constructor
*base
;
1035 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1040 base
= expr
->value
.constructor
;
1041 expr
->value
.constructor
= NULL
;
1043 rank
= ref
->u
.ar
.as
->rank
;
1045 if (expr
->shape
== NULL
)
1046 expr
->shape
= gfc_get_shape (rank
);
1048 mpz_init_set_ui (delta_mpz
, one
);
1049 mpz_init_set_ui (nelts
, one
);
1052 /* Do the initialization now, so that we can cleanup without
1053 keeping track of where we were. */
1054 for (d
= 0; d
< rank
; d
++)
1056 mpz_init (delta
[d
]);
1057 mpz_init (start
[d
]);
1060 mpz_init (stride
[d
]);
1064 /* Build the counters to clock through the array reference. */
1066 for (d
= 0; d
< rank
; d
++)
1068 /* Make this stretch of code easier on the eye! */
1069 begin
= ref
->u
.ar
.start
[d
];
1070 finish
= ref
->u
.ar
.end
[d
];
1071 step
= ref
->u
.ar
.stride
[d
];
1072 lower
= ref
->u
.ar
.as
->lower
[d
];
1073 upper
= ref
->u
.ar
.as
->upper
[d
];
1075 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1079 if (begin
->expr_type
!= EXPR_ARRAY
)
1085 gcc_assert (begin
->rank
== 1);
1086 gcc_assert (begin
->shape
);
1088 vecsub
[d
] = begin
->value
.constructor
;
1089 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1090 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1091 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1094 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1096 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1097 || mpz_cmp (c
->expr
->value
.integer
,
1098 lower
->value
.integer
) < 0)
1100 gfc_error ("index in dimension %d is out of bounds "
1101 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1109 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1110 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1111 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1117 /* Obtain the stride. */
1119 mpz_set (stride
[d
], step
->value
.integer
);
1121 mpz_set_ui (stride
[d
], one
);
1123 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1124 mpz_set_ui (stride
[d
], one
);
1126 /* Obtain the start value for the index. */
1128 mpz_set (start
[d
], begin
->value
.integer
);
1130 mpz_set (start
[d
], lower
->value
.integer
);
1132 mpz_set (ctr
[d
], start
[d
]);
1134 /* Obtain the end value for the index. */
1136 mpz_set (end
[d
], finish
->value
.integer
);
1138 mpz_set (end
[d
], upper
->value
.integer
);
1140 /* Separate 'if' because elements sometimes arrive with
1142 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1143 mpz_set (end
[d
], begin
->value
.integer
);
1145 /* Check the bounds. */
1146 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1147 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1148 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1149 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1151 gfc_error ("index in dimension %d is out of bounds "
1152 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1157 /* Calculate the number of elements and the shape. */
1158 mpz_set (tmp_mpz
, stride
[d
]);
1159 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1160 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1161 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1162 mpz_mul (nelts
, nelts
, tmp_mpz
);
1164 /* An element reference reduces the rank of the expression; don't
1165 add anything to the shape array. */
1166 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1167 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1170 /* Calculate the 'stride' (=delta) for conversion of the
1171 counter values into the index along the constructor. */
1172 mpz_set (delta
[d
], delta_mpz
);
1173 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1174 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1175 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1182 /* Now clock through the array reference, calculating the index in
1183 the source constructor and transferring the elements to the new
1185 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1187 if (ref
->u
.ar
.offset
)
1188 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1190 mpz_init_set_ui (ptr
, 0);
1193 for (d
= 0; d
< rank
; d
++)
1195 mpz_set (tmp_mpz
, ctr
[d
]);
1196 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1197 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1198 mpz_add (ptr
, ptr
, tmp_mpz
);
1200 if (!incr_ctr
) continue;
1202 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1204 gcc_assert(vecsub
[d
]);
1206 if (!vecsub
[d
]->next
)
1207 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1210 vecsub
[d
] = vecsub
[d
]->next
;
1213 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1217 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1219 if (mpz_cmp_ui (stride
[d
], 0) > 0
1220 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1221 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1222 mpz_set (ctr
[d
], start
[d
]);
1228 /* There must be a better way of dealing with negative strides
1229 than resetting the index and the constructor pointer! */
1230 if (mpz_cmp (ptr
, index
) < 0)
1232 mpz_set_ui (index
, 0);
1236 while (mpz_cmp (ptr
, index
) > 0)
1238 mpz_add_ui (index
, index
, one
);
1242 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1250 mpz_clear (delta_mpz
);
1251 mpz_clear (tmp_mpz
);
1253 for (d
= 0; d
< rank
; d
++)
1255 mpz_clear (delta
[d
]);
1256 mpz_clear (start
[d
]);
1259 mpz_clear (stride
[d
]);
1261 gfc_free_constructor (base
);
1265 /* Pull a substring out of an expression. */
1268 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1274 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1275 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1278 *newp
= gfc_copy_expr (p
);
1279 chr
= p
->value
.character
.string
;
1280 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1281 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1283 (*newp
)->value
.character
.length
= end
- start
+ 1;
1284 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1285 (*newp
)->value
.character
.length
);
1291 /* Simplify a subobject reference of a constructor. This occurs when
1292 parameter variable values are substituted. */
1295 simplify_const_ref (gfc_expr
*p
)
1297 gfc_constructor
*cons
;
1302 switch (p
->ref
->type
)
1305 switch (p
->ref
->u
.ar
.type
)
1308 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1315 remove_subobject_ref (p
, cons
);
1319 if (find_array_section (p
, p
->ref
) == FAILURE
)
1321 p
->ref
->u
.ar
.type
= AR_FULL
;
1326 if (p
->ref
->next
!= NULL
1327 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1329 cons
= p
->value
.constructor
;
1330 for (; cons
; cons
= cons
->next
)
1332 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1333 simplify_const_ref (cons
->expr
);
1336 gfc_free_ref_list (p
->ref
);
1347 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1348 remove_subobject_ref (p
, cons
);
1352 if (find_substring_ref (p
, &newp
) == FAILURE
)
1355 gfc_replace_expr (p
, newp
);
1356 gfc_free_ref_list (p
->ref
);
1366 /* Simplify a chain of references. */
1369 simplify_ref_chain (gfc_ref
*ref
, int type
)
1373 for (; ref
; ref
= ref
->next
)
1378 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1380 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1382 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1384 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1390 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1392 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1404 /* Try to substitute the value of a parameter variable. */
1406 simplify_parameter_variable (gfc_expr
*p
, int type
)
1411 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1417 /* Do not copy subobject refs for constant. */
1418 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1419 e
->ref
= copy_ref (p
->ref
);
1420 t
= gfc_simplify_expr (e
, type
);
1422 /* Only use the simplification if it eliminated all subobject
1424 if (t
== SUCCESS
&& !e
->ref
)
1425 gfc_replace_expr (p
, e
);
1432 /* Given an expression, simplify it by collapsing constant
1433 expressions. Most simplification takes place when the expression
1434 tree is being constructed. If an intrinsic function is simplified
1435 at some point, we get called again to collapse the result against
1438 We work by recursively simplifying expression nodes, simplifying
1439 intrinsic functions where possible, which can lead to further
1440 constant collapsing. If an operator has constant operand(s), we
1441 rip the expression apart, and rebuild it, hoping that it becomes
1444 The expression type is defined for:
1445 0 Basic expression parsing
1446 1 Simplifying array constructors -- will substitute
1448 Returns FAILURE on error, SUCCESS otherwise.
1449 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1452 gfc_simplify_expr (gfc_expr
*p
, int type
)
1454 gfc_actual_arglist
*ap
;
1459 switch (p
->expr_type
)
1466 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1467 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1470 if (p
->value
.function
.isym
!= NULL
1471 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1476 case EXPR_SUBSTRING
:
1477 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1480 if (gfc_is_constant_expr (p
))
1485 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1486 start
--; /* Convert from one-based to zero-based. */
1487 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1488 s
= gfc_getmem (end
- start
+ 2);
1489 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1490 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1491 gfc_free (p
->value
.character
.string
);
1492 p
->value
.character
.string
= s
;
1493 p
->value
.character
.length
= end
- start
;
1494 p
->ts
.cl
= gfc_get_charlen ();
1495 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1496 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1497 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1498 gfc_free_ref_list (p
->ref
);
1500 p
->expr_type
= EXPR_CONSTANT
;
1505 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1510 /* Only substitute array parameter variables if we are in an
1511 initialization expression, or we want a subsection. */
1512 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1513 && (gfc_init_expr
|| p
->ref
1514 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1516 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1523 gfc_simplify_iterator_var (p
);
1526 /* Simplify subcomponent references. */
1527 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1532 case EXPR_STRUCTURE
:
1534 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1537 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1540 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1541 && p
->ref
->u
.ar
.type
== AR_FULL
)
1542 gfc_expand_constructor (p
);
1544 if (simplify_const_ref (p
) == FAILURE
)
1554 /* Returns the type of an expression with the exception that iterator
1555 variables are automatically integers no matter what else they may
1561 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1568 /* Check an intrinsic arithmetic operation to see if it is consistent
1569 with some type of expression. */
1571 static try check_init_expr (gfc_expr
*);
1574 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1576 gfc_expr
*op1
= e
->value
.op
.op1
;
1577 gfc_expr
*op2
= e
->value
.op
.op2
;
1579 if ((*check_function
) (op1
) == FAILURE
)
1582 switch (e
->value
.op
.operator)
1584 case INTRINSIC_UPLUS
:
1585 case INTRINSIC_UMINUS
:
1586 if (!numeric_type (et0 (op1
)))
1596 if ((*check_function
) (op2
) == FAILURE
)
1599 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1600 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1602 gfc_error ("Numeric or CHARACTER operands are required in "
1603 "expression at %L", &e
->where
);
1608 case INTRINSIC_PLUS
:
1609 case INTRINSIC_MINUS
:
1610 case INTRINSIC_TIMES
:
1611 case INTRINSIC_DIVIDE
:
1612 case INTRINSIC_POWER
:
1613 if ((*check_function
) (op2
) == FAILURE
)
1616 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1619 if (e
->value
.op
.operator == INTRINSIC_POWER
1620 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1622 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1623 "exponent in an initialization "
1624 "expression at %L", &op2
->where
)
1631 case INTRINSIC_CONCAT
:
1632 if ((*check_function
) (op2
) == FAILURE
)
1635 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1637 gfc_error ("Concatenation operator in expression at %L "
1638 "must have two CHARACTER operands", &op1
->where
);
1642 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1644 gfc_error ("Concat operator at %L must concatenate strings of the "
1645 "same kind", &e
->where
);
1652 if (et0 (op1
) != BT_LOGICAL
)
1654 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1655 "operand", &op1
->where
);
1664 case INTRINSIC_NEQV
:
1665 if ((*check_function
) (op2
) == FAILURE
)
1668 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1670 gfc_error ("LOGICAL operands are required in expression at %L",
1677 case INTRINSIC_PARENTHESES
:
1681 gfc_error ("Only intrinsic operators can be used in expression at %L",
1689 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1696 /* Certain inquiry functions are specifically allowed to have variable
1697 arguments, which is an exception to the normal requirement that an
1698 initialization function have initialization arguments. We head off
1699 this problem here. */
1702 check_inquiry (gfc_expr
*e
, int not_restricted
)
1706 /* FIXME: This should be moved into the intrinsic definitions,
1707 to eliminate this ugly hack. */
1708 static const char * const inquiry_function
[] = {
1709 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1710 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1711 "lbound", "ubound", NULL
1716 /* An undeclared parameter will get us here (PR25018). */
1717 if (e
->symtree
== NULL
)
1720 name
= e
->symtree
->n
.sym
->name
;
1722 for (i
= 0; inquiry_function
[i
]; i
++)
1723 if (strcmp (inquiry_function
[i
], name
) == 0)
1726 if (inquiry_function
[i
] == NULL
)
1729 e
= e
->value
.function
.actual
->expr
;
1731 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1734 /* At this point we have an inquiry function with a variable argument. The
1735 type of the variable might be undefined, but we need it now, because the
1736 arguments of these functions are allowed to be undefined. */
1738 if (e
->ts
.type
== BT_UNKNOWN
)
1740 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1741 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1745 e
->ts
= e
->symtree
->n
.sym
->ts
;
1748 /* Assumed character length will not reduce to a constant expression
1749 with LEN, as required by the standard. */
1750 if (i
== 4 && not_restricted
1751 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1752 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1753 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1754 "variable '%s' in constant expression at %L",
1755 e
->symtree
->n
.sym
->name
, &e
->where
);
1761 /* Verify that an expression is an initialization expression. A side
1762 effect is that the expression tree is reduced to a single constant
1763 node if all goes well. This would normally happen when the
1764 expression is constructed but function references are assumed to be
1765 intrinsics in the context of initialization expressions. If
1766 FAILURE is returned an error message has been generated. */
1769 check_init_expr (gfc_expr
*e
)
1771 gfc_actual_arglist
*ap
;
1778 switch (e
->expr_type
)
1781 t
= check_intrinsic_op (e
, check_init_expr
);
1783 t
= gfc_simplify_expr (e
, 0);
1790 if (check_inquiry (e
, 1) != SUCCESS
)
1793 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1794 if (check_init_expr (ap
->expr
) == FAILURE
)
1803 m
= gfc_intrinsic_func_interface (e
, 0);
1806 gfc_error ("Function '%s' in initialization expression at %L "
1807 "must be an intrinsic function",
1808 e
->symtree
->n
.sym
->name
, &e
->where
);
1819 if (gfc_check_iter_variable (e
) == SUCCESS
)
1822 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1824 t
= simplify_parameter_variable (e
, 0);
1828 if (gfc_in_match_data ())
1831 gfc_error ("Parameter '%s' at %L has not been declared or is "
1832 "a variable, which does not reduce to a constant "
1833 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1842 case EXPR_SUBSTRING
:
1843 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1847 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1849 t
= gfc_simplify_expr (e
, 0);
1853 case EXPR_STRUCTURE
:
1854 t
= gfc_check_constructor (e
, check_init_expr
);
1858 t
= gfc_check_constructor (e
, check_init_expr
);
1862 t
= gfc_expand_constructor (e
);
1866 t
= gfc_check_constructor_type (e
);
1870 gfc_internal_error ("check_init_expr(): Unknown expression type");
1877 /* Match an initialization expression. We work by first matching an
1878 expression, then reducing it to a constant. */
1881 gfc_match_init_expr (gfc_expr
**result
)
1887 m
= gfc_match_expr (&expr
);
1892 t
= gfc_resolve_expr (expr
);
1894 t
= check_init_expr (expr
);
1899 gfc_free_expr (expr
);
1903 if (expr
->expr_type
== EXPR_ARRAY
1904 && (gfc_check_constructor_type (expr
) == FAILURE
1905 || gfc_expand_constructor (expr
) == FAILURE
))
1907 gfc_free_expr (expr
);
1911 /* Not all inquiry functions are simplified to constant expressions
1912 so it is necessary to call check_inquiry again. */
1913 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
1914 && !gfc_in_match_data ())
1916 gfc_error ("Initialization expression didn't reduce %C");
1926 static try check_restricted (gfc_expr
*);
1928 /* Given an actual argument list, test to see that each argument is a
1929 restricted expression and optionally if the expression type is
1930 integer or character. */
1933 restricted_args (gfc_actual_arglist
*a
)
1935 for (; a
; a
= a
->next
)
1937 if (check_restricted (a
->expr
) == FAILURE
)
1945 /************* Restricted/specification expressions *************/
1948 /* Make sure a non-intrinsic function is a specification function. */
1951 external_spec_function (gfc_expr
*e
)
1955 f
= e
->value
.function
.esym
;
1957 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1959 gfc_error ("Specification function '%s' at %L cannot be a statement "
1960 "function", f
->name
, &e
->where
);
1964 if (f
->attr
.proc
== PROC_INTERNAL
)
1966 gfc_error ("Specification function '%s' at %L cannot be an internal "
1967 "function", f
->name
, &e
->where
);
1971 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1973 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1978 if (f
->attr
.recursive
)
1980 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1981 f
->name
, &e
->where
);
1985 return restricted_args (e
->value
.function
.actual
);
1989 /* Check to see that a function reference to an intrinsic is a
1990 restricted expression. */
1993 restricted_intrinsic (gfc_expr
*e
)
1995 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1996 if (check_inquiry (e
, 0) == SUCCESS
)
1999 return restricted_args (e
->value
.function
.actual
);
2003 /* Verify that an expression is a restricted expression. Like its
2004 cousin check_init_expr(), an error message is generated if we
2008 check_restricted (gfc_expr
*e
)
2016 switch (e
->expr_type
)
2019 t
= check_intrinsic_op (e
, check_restricted
);
2021 t
= gfc_simplify_expr (e
, 0);
2026 t
= e
->value
.function
.esym
? external_spec_function (e
)
2027 : restricted_intrinsic (e
);
2032 sym
= e
->symtree
->n
.sym
;
2035 if (sym
->attr
.optional
)
2037 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2038 sym
->name
, &e
->where
);
2042 if (sym
->attr
.intent
== INTENT_OUT
)
2044 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2045 sym
->name
, &e
->where
);
2049 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2050 processed in resolve.c(resolve_formal_arglist). This is done so
2051 that host associated dummy array indices are accepted (PR23446).
2052 This mechanism also does the same for the specification expressions
2053 of array-valued functions. */
2054 if (sym
->attr
.in_common
2055 || sym
->attr
.use_assoc
2057 || sym
->ns
!= gfc_current_ns
2058 || (sym
->ns
->proc_name
!= NULL
2059 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2060 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2066 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2067 sym
->name
, &e
->where
);
2076 case EXPR_SUBSTRING
:
2077 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2081 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2083 t
= gfc_simplify_expr (e
, 0);
2087 case EXPR_STRUCTURE
:
2088 t
= gfc_check_constructor (e
, check_restricted
);
2092 t
= gfc_check_constructor (e
, check_restricted
);
2096 gfc_internal_error ("check_restricted(): Unknown expression type");
2103 /* Check to see that an expression is a specification expression. If
2104 we return FAILURE, an error has been generated. */
2107 gfc_specification_expr (gfc_expr
*e
)
2112 if (e
->ts
.type
!= BT_INTEGER
)
2114 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2120 gfc_error ("Expression at %L must be scalar", &e
->where
);
2124 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2127 return check_restricted (e
);
2131 /************** Expression conformance checks. *************/
2133 /* Given two expressions, make sure that the arrays are conformable. */
2136 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2138 int op1_flag
, op2_flag
, d
;
2139 mpz_t op1_size
, op2_size
;
2142 if (op1
->rank
== 0 || op2
->rank
== 0)
2145 if (op1
->rank
!= op2
->rank
)
2147 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2154 for (d
= 0; d
< op1
->rank
; d
++)
2156 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2157 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2159 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2161 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2162 _(optype_msgid
), &op1
->where
, d
+ 1,
2163 (int) mpz_get_si (op1_size
),
2164 (int) mpz_get_si (op2_size
));
2170 mpz_clear (op1_size
);
2172 mpz_clear (op2_size
);
2182 /* Given an assignable expression and an arbitrary expression, make
2183 sure that the assignment can take place. */
2186 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2192 sym
= lvalue
->symtree
->n
.sym
;
2194 /* Check INTENT(IN), unless the object itself is the component or
2195 sub-component of a pointer. */
2196 has_pointer
= sym
->attr
.pointer
;
2198 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2199 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2205 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2207 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2208 sym
->name
, &lvalue
->where
);
2212 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2213 variable local to a function subprogram. Its existence begins when
2214 execution of the function is initiated and ends when execution of the
2215 function is terminated.....
2216 Therefore, the left hand side is no longer a varaiable, when it is: */
2217 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2218 && !sym
->attr
.external
)
2223 /* (i) Use associated; */
2224 if (sym
->attr
.use_assoc
)
2227 /* (ii) The assignment is in the main program; or */
2228 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2231 /* (iii) A module or internal procedure.... */
2232 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2233 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2234 && gfc_current_ns
->parent
2235 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2236 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2237 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2239 /* .... that is not a function.... */
2240 if (!gfc_current_ns
->proc_name
->attr
.function
)
2243 /* .... or is not an entry and has a different name. */
2244 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2250 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2255 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2257 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2258 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2262 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2264 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2269 if (rvalue
->expr_type
== EXPR_NULL
)
2271 gfc_error ("NULL appears on right-hand side in assignment at %L",
2276 if (sym
->attr
.cray_pointee
2277 && lvalue
->ref
!= NULL
2278 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2279 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2281 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2282 "is illegal", &lvalue
->where
);
2286 /* This is possibly a typo: x = f() instead of x => f() */
2287 if (gfc_option
.warn_surprising
2288 && rvalue
->expr_type
== EXPR_FUNCTION
2289 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2290 gfc_warning ("POINTER valued function appears on right-hand side of "
2291 "assignment at %L", &rvalue
->where
);
2293 /* Check size of array assignments. */
2294 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2295 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2298 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2303 /* Numeric can be converted to any other numeric. And Hollerith can be
2304 converted to any other type. */
2305 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2306 || rvalue
->ts
.type
== BT_HOLLERITH
)
2309 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2312 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2313 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2314 gfc_typename (&lvalue
->ts
));
2319 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2323 /* Check that a pointer assignment is OK. We first check lvalue, and
2324 we only check rvalue if it's not an assignment to NULL() or a
2325 NULLIFY statement. */
2328 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2330 symbol_attribute attr
;
2333 int pointer
, check_intent_in
;
2335 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2337 gfc_error ("Pointer assignment target is not a POINTER at %L",
2342 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2343 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2345 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2346 "l-value since it is a procedure",
2347 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2352 /* Check INTENT(IN), unless the object itself is the component or
2353 sub-component of a pointer. */
2354 check_intent_in
= 1;
2355 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2357 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2360 check_intent_in
= 0;
2362 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2366 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2368 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2369 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2375 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2379 is_pure
= gfc_pure (NULL
);
2381 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2383 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2387 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2388 kind, etc for lvalue and rvalue must match, and rvalue must be a
2389 pure variable if we're in a pure function. */
2390 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2393 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2395 gfc_error ("Different types in pointer assignment at %L",
2400 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2402 gfc_error ("Different kind type parameters in pointer "
2403 "assignment at %L", &lvalue
->where
);
2407 if (lvalue
->rank
!= rvalue
->rank
)
2409 gfc_error ("Different ranks in pointer assignment at %L",
2414 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2415 if (rvalue
->expr_type
== EXPR_NULL
)
2418 if (lvalue
->ts
.type
== BT_CHARACTER
2419 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2420 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2421 rvalue
->ts
.cl
->length
)) == 1)
2423 gfc_error ("Different character lengths in pointer "
2424 "assignment at %L", &lvalue
->where
);
2428 attr
= gfc_expr_attr (rvalue
);
2429 if (!attr
.target
&& !attr
.pointer
)
2431 gfc_error ("Pointer assignment target is neither TARGET "
2432 "nor POINTER at %L", &rvalue
->where
);
2436 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2438 gfc_error ("Bad target in pointer assignment in PURE "
2439 "procedure at %L", &rvalue
->where
);
2442 if (gfc_has_vector_index (rvalue
))
2444 gfc_error ("Pointer assignment with vector subscript "
2445 "on rhs at %L", &rvalue
->where
);
2449 if (attr
.protected && attr
.use_assoc
)
2451 gfc_error ("Pointer assigment target has PROTECTED "
2452 "attribute at %L", &rvalue
->where
);
2460 /* Relative of gfc_check_assign() except that the lvalue is a single
2461 symbol. Used for initialization assignments. */
2464 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2469 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2471 lvalue
.expr_type
= EXPR_VARIABLE
;
2472 lvalue
.ts
= sym
->ts
;
2474 lvalue
.rank
= sym
->as
->rank
;
2475 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2476 lvalue
.symtree
->n
.sym
= sym
;
2477 lvalue
.where
= sym
->declared_at
;
2479 if (sym
->attr
.pointer
)
2480 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2482 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2484 gfc_free (lvalue
.symtree
);
2490 /* Get an expression for a default initializer. */
2493 gfc_default_initializer (gfc_typespec
*ts
)
2495 gfc_constructor
*tail
;
2501 /* See if we have a default initializer. */
2502 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2504 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2505 init
= gfc_get_expr ();
2511 /* Build the constructor. */
2512 init
->expr_type
= EXPR_STRUCTURE
;
2514 init
->where
= ts
->derived
->declared_at
;
2516 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2519 init
->value
.constructor
= tail
= gfc_get_constructor ();
2522 tail
->next
= gfc_get_constructor ();
2527 tail
->expr
= gfc_copy_expr (c
->initializer
);
2531 tail
->expr
= gfc_get_expr ();
2532 tail
->expr
->expr_type
= EXPR_NULL
;
2533 tail
->expr
->ts
= c
->ts
;
2540 /* Given a symbol, create an expression node with that symbol as a
2541 variable. If the symbol is array valued, setup a reference of the
2545 gfc_get_variable_expr (gfc_symtree
*var
)
2549 e
= gfc_get_expr ();
2550 e
->expr_type
= EXPR_VARIABLE
;
2552 e
->ts
= var
->n
.sym
->ts
;
2554 if (var
->n
.sym
->as
!= NULL
)
2556 e
->rank
= var
->n
.sym
->as
->rank
;
2557 e
->ref
= gfc_get_ref ();
2558 e
->ref
->type
= REF_ARRAY
;
2559 e
->ref
->u
.ar
.type
= AR_FULL
;
2566 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2569 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2571 gfc_actual_arglist
*arg
;
2578 switch (expr
->expr_type
)
2581 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2582 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2586 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2587 gfc_expr_set_symbols_referenced (arg
->expr
);
2591 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2596 case EXPR_SUBSTRING
:
2599 case EXPR_STRUCTURE
:
2601 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2602 gfc_expr_set_symbols_referenced (c
->expr
);
2610 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2614 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2616 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2617 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2618 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2626 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2627 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);