1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
38 gfc_clear_ts (&e
->ts
);
42 e
->con_by_offset
= NULL
;
47 /* Free an argument list and everything below it. */
50 gfc_free_actual_arglist (gfc_actual_arglist
* a1
)
52 gfc_actual_arglist
*a2
;
57 gfc_free_expr (a1
->expr
);
64 /* Copy an arglist structure and all of the arguments. */
67 gfc_copy_actual_arglist (gfc_actual_arglist
* p
)
69 gfc_actual_arglist
*head
, *tail
, *new;
73 for (; p
; p
= p
->next
)
75 new = gfc_get_actual_arglist ();
78 new->expr
= gfc_copy_expr (p
->expr
);
93 /* Free a list of reference structures. */
96 gfc_free_ref_list (gfc_ref
* p
)
108 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
110 gfc_free_expr (p
->u
.ar
.start
[i
]);
111 gfc_free_expr (p
->u
.ar
.end
[i
]);
112 gfc_free_expr (p
->u
.ar
.stride
[i
]);
118 gfc_free_expr (p
->u
.ss
.start
);
119 gfc_free_expr (p
->u
.ss
.end
);
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
137 free_expr0 (gfc_expr
* e
)
141 switch (e
->expr_type
)
146 gfc_free (e
->value
.character
.string
);
153 mpz_clear (e
->value
.integer
);
157 mpfr_clear (e
->value
.real
);
162 gfc_free (e
->value
.character
.string
);
166 mpfr_clear (e
->value
.complex.r
);
167 mpfr_clear (e
->value
.complex.i
);
177 if (e
->value
.op
.op1
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op1
);
179 if (e
->value
.op
.op2
!= NULL
)
180 gfc_free_expr (e
->value
.op
.op2
);
184 gfc_free_actual_arglist (e
->value
.function
.actual
);
192 gfc_free_constructor (e
->value
.constructor
);
196 gfc_free (e
->value
.character
.string
);
203 gfc_internal_error ("free_expr0(): Bad expr type");
206 /* Free a shape array. */
207 if (e
->shape
!= NULL
)
209 for (n
= 0; n
< e
->rank
; n
++)
210 mpz_clear (e
->shape
[n
]);
215 gfc_free_ref_list (e
->ref
);
217 memset (e
, '\0', sizeof (gfc_expr
));
221 /* Free an expression node and everything beneath it. */
224 gfc_free_expr (gfc_expr
* e
)
229 if (e
->con_by_offset
)
230 splay_tree_delete (e
->con_by_offset
);
236 /* Graft the *src expression onto the *dest subexpression. */
239 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
249 /* Try to extract an integer constant from the passed expression node.
250 Returns an error message or NULL if the result is set. It is
251 tempting to generate an error and return SUCCESS or FAILURE, but
252 failure is OK for some callers. */
255 gfc_extract_int (gfc_expr
* expr
, int *result
)
258 if (expr
->expr_type
!= EXPR_CONSTANT
)
259 return _("Constant expression required at %C");
261 if (expr
->ts
.type
!= BT_INTEGER
)
262 return _("Integer expression required at %C");
264 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
265 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
267 return _("Integer value too large in expression at %C");
270 *result
= (int) mpz_get_si (expr
->value
.integer
);
276 /* Recursively copy a list of reference structures. */
279 copy_ref (gfc_ref
* src
)
287 dest
= gfc_get_ref ();
288 dest
->type
= src
->type
;
293 ar
= gfc_copy_array_ref (&src
->u
.ar
);
299 dest
->u
.c
= src
->u
.c
;
303 dest
->u
.ss
= src
->u
.ss
;
304 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
305 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
309 dest
->next
= copy_ref (src
->next
);
315 /* Detect whether an expression has any vector index array
319 gfc_has_vector_index (gfc_expr
*e
)
323 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
324 if (ref
->type
== REF_ARRAY
)
325 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
326 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
332 /* Copy a shape array. */
335 gfc_copy_shape (mpz_t
* shape
, int rank
)
343 new_shape
= gfc_get_shape (rank
);
345 for (n
= 0; n
< rank
; n
++)
346 mpz_init_set (new_shape
[n
], shape
[n
]);
352 /* Copy a shape array excluding dimension N, where N is an integer
353 constant expression. Dimensions are numbered in fortran style --
356 So, if the original shape array contains R elements
357 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
358 the result contains R-1 elements:
359 { s1 ... sN-1 sN+1 ... sR-1}
361 If anything goes wrong -- N is not a constant, its value is out
362 of range -- or anything else, just returns NULL.
366 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
368 mpz_t
*new_shape
, *s
;
374 || dim
->expr_type
!= EXPR_CONSTANT
375 || dim
->ts
.type
!= BT_INTEGER
)
378 n
= mpz_get_si (dim
->value
.integer
);
379 n
--; /* Convert to zero based index */
380 if (n
< 0 || n
>= rank
)
383 s
= new_shape
= gfc_get_shape (rank
-1);
385 for (i
= 0; i
< rank
; i
++)
389 mpz_init_set (*s
, shape
[i
]);
396 /* Given an expression pointer, return a copy of the expression. This
397 subroutine is recursive. */
400 gfc_copy_expr (gfc_expr
* p
)
411 switch (q
->expr_type
)
414 s
= gfc_getmem (p
->value
.character
.length
+ 1);
415 q
->value
.character
.string
= s
;
417 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
423 s
= gfc_getmem (p
->value
.character
.length
+ 1);
424 q
->value
.character
.string
= s
;
426 memcpy (s
, p
->value
.character
.string
,
427 p
->value
.character
.length
+ 1);
433 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.real
);
439 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
443 gfc_set_model_kind (q
->ts
.kind
);
444 mpfr_init (q
->value
.complex.r
);
445 mpfr_init (q
->value
.complex.i
);
446 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
447 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
452 s
= gfc_getmem (p
->value
.character
.length
+ 1);
453 q
->value
.character
.string
= s
;
455 memcpy (s
, p
->value
.character
.string
,
456 p
->value
.character
.length
+ 1);
461 break; /* Already done */
465 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
472 switch (q
->value
.op
.operator)
475 case INTRINSIC_UPLUS
:
476 case INTRINSIC_UMINUS
:
477 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
480 default: /* Binary operators */
481 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
482 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
489 q
->value
.function
.actual
=
490 gfc_copy_actual_arglist (p
->value
.function
.actual
);
495 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
503 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
505 q
->ref
= copy_ref (p
->ref
);
511 /* Return the maximum kind of two expressions. In general, higher
512 kind numbers mean more precision for numeric types. */
515 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
518 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
522 /* Returns nonzero if the type is numeric, zero otherwise. */
525 numeric_type (bt type
)
528 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
532 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
535 gfc_numeric_ts (gfc_typespec
* ts
)
538 return numeric_type (ts
->type
);
542 /* Returns an expression node that is an integer constant. */
551 p
->expr_type
= EXPR_CONSTANT
;
552 p
->ts
.type
= BT_INTEGER
;
553 p
->ts
.kind
= gfc_default_integer_kind
;
555 p
->where
= gfc_current_locus
;
556 mpz_init_set_si (p
->value
.integer
, i
);
562 /* Returns an expression node that is a logical constant. */
565 gfc_logical_expr (int i
, locus
* where
)
571 p
->expr_type
= EXPR_CONSTANT
;
572 p
->ts
.type
= BT_LOGICAL
;
573 p
->ts
.kind
= gfc_default_logical_kind
;
576 where
= &gfc_current_locus
;
578 p
->value
.logical
= i
;
584 /* Return an expression node with an optional argument list attached.
585 A variable number of gfc_expr pointers are strung together in an
586 argument list with a NULL pointer terminating the list. */
589 gfc_build_conversion (gfc_expr
* e
)
594 p
->expr_type
= EXPR_FUNCTION
;
596 p
->value
.function
.actual
= NULL
;
598 p
->value
.function
.actual
= gfc_get_actual_arglist ();
599 p
->value
.function
.actual
->expr
= e
;
605 /* Given an expression node with some sort of numeric binary
606 expression, insert type conversions required to make the operands
609 The exception is that the operands of an exponential don't have to
610 have the same type. If possible, the base is promoted to the type
611 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
612 1.0**2 stays as it is. */
615 gfc_type_convert_binary (gfc_expr
* e
)
619 op1
= e
->value
.op
.op1
;
620 op2
= e
->value
.op
.op2
;
622 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
624 gfc_clear_ts (&e
->ts
);
628 /* Kind conversions of same type. */
629 if (op1
->ts
.type
== op2
->ts
.type
)
632 if (op1
->ts
.kind
== op2
->ts
.kind
)
634 /* No type conversions. */
639 if (op1
->ts
.kind
> op2
->ts
.kind
)
640 gfc_convert_type (op2
, &op1
->ts
, 2);
642 gfc_convert_type (op1
, &op2
->ts
, 2);
648 /* Integer combined with real or complex. */
649 if (op2
->ts
.type
== BT_INTEGER
)
653 /* Special case for ** operator. */
654 if (e
->value
.op
.operator == INTRINSIC_POWER
)
657 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
661 if (op1
->ts
.type
== BT_INTEGER
)
664 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
668 /* Real combined with complex. */
669 e
->ts
.type
= BT_COMPLEX
;
670 if (op1
->ts
.kind
> op2
->ts
.kind
)
671 e
->ts
.kind
= op1
->ts
.kind
;
673 e
->ts
.kind
= op2
->ts
.kind
;
674 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
675 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
677 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
684 /* Function to determine if an expression is constant or not. This
685 function expects that the expression has already been simplified. */
688 gfc_is_constant_expr (gfc_expr
* e
)
691 gfc_actual_arglist
*arg
;
697 switch (e
->expr_type
)
700 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
701 && (e
->value
.op
.op2
== NULL
702 || gfc_is_constant_expr (e
->value
.op
.op2
)));
711 /* Call to intrinsic with at least one argument. */
713 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
715 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
717 if (!gfc_is_constant_expr (arg
->expr
))
731 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
732 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
737 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
738 if (!gfc_is_constant_expr (c
->expr
))
746 rv
= gfc_constant_ac (e
);
750 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
757 /* Try to collapse intrinsic expressions. */
760 simplify_intrinsic_op (gfc_expr
* p
, int type
)
762 gfc_expr
*op1
, *op2
, *result
;
764 if (p
->value
.op
.operator == INTRINSIC_USER
)
767 op1
= p
->value
.op
.op1
;
768 op2
= p
->value
.op
.op2
;
770 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
772 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
775 if (!gfc_is_constant_expr (op1
)
776 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
780 p
->value
.op
.op1
= NULL
;
781 p
->value
.op
.op2
= NULL
;
783 switch (p
->value
.op
.operator)
785 case INTRINSIC_UPLUS
:
786 case INTRINSIC_PARENTHESES
:
787 result
= gfc_uplus (op1
);
790 case INTRINSIC_UMINUS
:
791 result
= gfc_uminus (op1
);
795 result
= gfc_add (op1
, op2
);
798 case INTRINSIC_MINUS
:
799 result
= gfc_subtract (op1
, op2
);
802 case INTRINSIC_TIMES
:
803 result
= gfc_multiply (op1
, op2
);
806 case INTRINSIC_DIVIDE
:
807 result
= gfc_divide (op1
, op2
);
810 case INTRINSIC_POWER
:
811 result
= gfc_power (op1
, op2
);
814 case INTRINSIC_CONCAT
:
815 result
= gfc_concat (op1
, op2
);
819 result
= gfc_eq (op1
, op2
);
823 result
= gfc_ne (op1
, op2
);
827 result
= gfc_gt (op1
, op2
);
831 result
= gfc_ge (op1
, op2
);
835 result
= gfc_lt (op1
, op2
);
839 result
= gfc_le (op1
, op2
);
843 result
= gfc_not (op1
);
847 result
= gfc_and (op1
, op2
);
851 result
= gfc_or (op1
, op2
);
855 result
= gfc_eqv (op1
, op2
);
859 result
= gfc_neqv (op1
, op2
);
863 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
873 result
->rank
= p
->rank
;
874 result
->where
= p
->where
;
875 gfc_replace_expr (p
, result
);
881 /* Subroutine to simplify constructor expressions. Mutually recursive
882 with gfc_simplify_expr(). */
885 simplify_constructor (gfc_constructor
* c
, int type
)
888 for (; c
; c
= c
->next
)
891 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
892 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
893 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
896 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
904 /* Pull a single array element out of an array constructor. */
907 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
,
908 gfc_constructor
** rval
)
910 unsigned long nelemen
;
920 mpz_init_set_ui (offset
, 0);
922 for (i
= 0; i
< ar
->dimen
; i
++)
924 e
= gfc_copy_expr (ar
->start
[i
]);
925 if (e
->expr_type
!= EXPR_CONSTANT
)
931 /* Check the bounds. */
933 && (mpz_cmp (e
->value
.integer
,
934 ar
->as
->upper
[i
]->value
.integer
) > 0
935 || mpz_cmp (e
->value
.integer
,
936 ar
->as
->lower
[i
]->value
.integer
) < 0))
938 gfc_error ("index in dimension %d is out of bounds "
939 "at %L", i
+ 1, &ar
->c_where
[i
]);
945 mpz_sub (delta
, e
->value
.integer
,
946 ar
->as
->lower
[i
]->value
.integer
);
947 mpz_add (offset
, offset
, delta
);
952 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
973 /* Find a component of a structure constructor. */
975 static gfc_constructor
*
976 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
981 comp
= ref
->u
.c
.sym
->components
;
982 pick
= ref
->u
.c
.component
;
993 /* Replace an expression with the contents of a constructor, removing
994 the subobject reference in the process. */
997 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
1003 e
->ref
= p
->ref
->next
;
1004 p
->ref
->next
= NULL
;
1005 gfc_replace_expr (p
, e
);
1009 /* Pull an array section out of an array constructor. */
1012 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1018 long unsigned one
= 1;
1020 mpz_t start
[GFC_MAX_DIMENSIONS
];
1021 mpz_t end
[GFC_MAX_DIMENSIONS
];
1022 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1023 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1024 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1030 gfc_constructor
*cons
;
1031 gfc_constructor
*base
;
1037 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1042 base
= expr
->value
.constructor
;
1043 expr
->value
.constructor
= NULL
;
1045 rank
= ref
->u
.ar
.as
->rank
;
1047 if (expr
->shape
== NULL
)
1048 expr
->shape
= gfc_get_shape (rank
);
1050 mpz_init_set_ui (delta_mpz
, one
);
1051 mpz_init_set_ui (nelts
, one
);
1054 /* Do the initialization now, so that we can cleanup without
1055 keeping track of where we were. */
1056 for (d
= 0; d
< rank
; d
++)
1058 mpz_init (delta
[d
]);
1059 mpz_init (start
[d
]);
1062 mpz_init (stride
[d
]);
1066 /* Build the counters to clock through the array reference. */
1068 for (d
= 0; d
< rank
; d
++)
1070 /* Make this stretch of code easier on the eye! */
1071 begin
= ref
->u
.ar
.start
[d
];
1072 finish
= ref
->u
.ar
.end
[d
];
1073 step
= ref
->u
.ar
.stride
[d
];
1074 lower
= ref
->u
.ar
.as
->lower
[d
];
1075 upper
= ref
->u
.ar
.as
->upper
[d
];
1077 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1080 gcc_assert(begin
->expr_type
== EXPR_ARRAY
);
1081 gcc_assert(begin
->rank
== 1);
1082 gcc_assert(begin
->shape
);
1084 vecsub
[d
] = begin
->value
.constructor
;
1085 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1086 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1087 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1090 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1092 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1093 || mpz_cmp (c
->expr
->value
.integer
, lower
->value
.integer
) < 0)
1095 gfc_error ("index in dimension %d is out of bounds "
1096 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1104 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1105 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1106 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1112 /* Obtain the stride. */
1114 mpz_set (stride
[d
], step
->value
.integer
);
1116 mpz_set_ui (stride
[d
], one
);
1118 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1119 mpz_set_ui (stride
[d
], one
);
1121 /* Obtain the start value for the index. */
1123 mpz_set (start
[d
], begin
->value
.integer
);
1125 mpz_set (start
[d
], lower
->value
.integer
);
1127 mpz_set (ctr
[d
], start
[d
]);
1129 /* Obtain the end value for the index. */
1131 mpz_set (end
[d
], finish
->value
.integer
);
1133 mpz_set (end
[d
], upper
->value
.integer
);
1135 /* Separate 'if' because elements sometimes arrive with
1137 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1138 mpz_set (end
[d
], begin
->value
.integer
);
1140 /* Check the bounds. */
1141 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1142 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1143 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1144 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1146 gfc_error ("index in dimension %d is out of bounds "
1147 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1152 /* Calculate the number of elements and the shape. */
1153 mpz_abs (tmp_mpz
, stride
[d
]);
1154 mpz_div (tmp_mpz
, stride
[d
], tmp_mpz
);
1155 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1156 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1157 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1158 mpz_mul (nelts
, nelts
, tmp_mpz
);
1160 /* An element reference reduces the rank of the expression; don't add
1161 anything to the shape array. */
1162 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1163 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1166 /* Calculate the 'stride' (=delta) for conversion of the
1167 counter values into the index along the constructor. */
1168 mpz_set (delta
[d
], delta_mpz
);
1169 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1170 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1171 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1178 /* Now clock through the array reference, calculating the index in
1179 the source constructor and transferring the elements to the new
1181 for (idx
= 0; idx
< (int)mpz_get_si (nelts
); idx
++)
1183 if (ref
->u
.ar
.offset
)
1184 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1186 mpz_init_set_ui (ptr
, 0);
1189 for (d
= 0; d
< rank
; d
++)
1191 mpz_set (tmp_mpz
, ctr
[d
]);
1192 mpz_sub (tmp_mpz
, tmp_mpz
,
1193 ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1194 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1195 mpz_add (ptr
, ptr
, tmp_mpz
);
1197 if (!incr_ctr
) continue;
1199 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1201 gcc_assert(vecsub
[d
]);
1203 if (!vecsub
[d
]->next
)
1204 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1207 vecsub
[d
] = vecsub
[d
]->next
;
1210 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1214 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1216 if (mpz_cmp_ui (stride
[d
], 0) > 0 ?
1217 mpz_cmp (ctr
[d
], end
[d
]) > 0 :
1218 mpz_cmp (ctr
[d
], end
[d
]) < 0)
1219 mpz_set (ctr
[d
], start
[d
]);
1225 /* There must be a better way of dealing with negative strides
1226 than resetting the index and the constructor pointer! */
1227 if (mpz_cmp (ptr
, index
) < 0)
1229 mpz_set_ui (index
, 0);
1233 while (mpz_cmp (ptr
, index
) > 0)
1235 mpz_add_ui (index
, index
, one
);
1239 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1247 mpz_clear (delta_mpz
);
1248 mpz_clear (tmp_mpz
);
1250 for (d
= 0; d
< rank
; d
++)
1252 mpz_clear (delta
[d
]);
1253 mpz_clear (start
[d
]);
1256 mpz_clear (stride
[d
]);
1258 gfc_free_constructor (base
);
1262 /* Pull a substring out of an expression. */
1265 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1271 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1272 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1275 *newp
= gfc_copy_expr (p
);
1276 chr
= p
->value
.character
.string
;
1277 end
= (int)mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1278 start
= (int)mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1280 (*newp
)->value
.character
.length
= end
- start
+ 1;
1281 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1282 (*newp
)->value
.character
.length
);
1288 /* Simplify a subobject reference of a constructor. This occurs when
1289 parameter variable values are substituted. */
1292 simplify_const_ref (gfc_expr
* p
)
1294 gfc_constructor
*cons
;
1299 switch (p
->ref
->type
)
1302 switch (p
->ref
->u
.ar
.type
)
1305 if (find_array_element (p
->value
.constructor
,
1313 remove_subobject_ref (p
, cons
);
1317 if (find_array_section (p
, p
->ref
) == FAILURE
)
1319 p
->ref
->u
.ar
.type
= AR_FULL
;
1324 if (p
->ref
->next
!= NULL
1325 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1327 cons
= p
->value
.constructor
;
1328 for (; cons
; cons
= cons
->next
)
1330 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1331 simplify_const_ref (cons
->expr
);
1334 gfc_free_ref_list (p
->ref
);
1345 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1346 remove_subobject_ref (p
, cons
);
1350 if (find_substring_ref (p
, &newp
) == FAILURE
)
1353 gfc_replace_expr (p
, newp
);
1354 gfc_free_ref_list (p
->ref
);
1364 /* Simplify a chain of references. */
1367 simplify_ref_chain (gfc_ref
* ref
, int type
)
1371 for (; ref
; ref
= ref
->next
)
1376 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1378 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1381 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1384 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1392 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1394 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1406 /* Try to substitute the value of a parameter variable. */
1408 simplify_parameter_variable (gfc_expr
* p
, int type
)
1413 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1419 /* Do not copy subobject refs for constant. */
1420 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1421 e
->ref
= copy_ref (p
->ref
);
1422 t
= gfc_simplify_expr (e
, type
);
1424 /* Only use the simplification if it eliminated all subobject
1426 if (t
== SUCCESS
&& ! e
->ref
)
1427 gfc_replace_expr (p
, e
);
1434 /* Given an expression, simplify it by collapsing constant
1435 expressions. Most simplification takes place when the expression
1436 tree is being constructed. If an intrinsic function is simplified
1437 at some point, we get called again to collapse the result against
1440 We work by recursively simplifying expression nodes, simplifying
1441 intrinsic functions where possible, which can lead to further
1442 constant collapsing. If an operator has constant operand(s), we
1443 rip the expression apart, and rebuild it, hoping that it becomes
1446 The expression type is defined for:
1447 0 Basic expression parsing
1448 1 Simplifying array constructors -- will substitute
1450 Returns FAILURE on error, SUCCESS otherwise.
1451 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1454 gfc_simplify_expr (gfc_expr
* p
, int type
)
1456 gfc_actual_arglist
*ap
;
1461 switch (p
->expr_type
)
1468 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1469 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1472 if (p
->value
.function
.isym
!= NULL
1473 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1478 case EXPR_SUBSTRING
:
1479 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1482 if (gfc_is_constant_expr (p
))
1487 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1488 start
--; /* Convert from one-based to zero-based. */
1489 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1490 s
= gfc_getmem (end
- start
+ 2);
1491 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1492 s
[end
-start
+1] = '\0'; /* TODO: C-style string for debugging. */
1493 gfc_free (p
->value
.character
.string
);
1494 p
->value
.character
.string
= s
;
1495 p
->value
.character
.length
= end
- start
;
1496 p
->ts
.cl
= gfc_get_charlen ();
1497 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1498 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1499 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1500 gfc_free_ref_list (p
->ref
);
1502 p
->expr_type
= EXPR_CONSTANT
;
1507 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1512 /* Only substitute array parameter variables if we are in an
1513 initialization expression, or we want a subsection. */
1514 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1515 && (gfc_init_expr
|| p
->ref
1516 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1518 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1525 gfc_simplify_iterator_var (p
);
1528 /* Simplify subcomponent references. */
1529 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1534 case EXPR_STRUCTURE
:
1536 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1539 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1542 if (p
->expr_type
== EXPR_ARRAY
1543 && p
->ref
&& p
->ref
->type
== REF_ARRAY
1544 && p
->ref
->u
.ar
.type
== AR_FULL
)
1545 gfc_expand_constructor (p
);
1547 if (simplify_const_ref (p
) == FAILURE
)
1557 /* Returns the type of an expression with the exception that iterator
1558 variables are automatically integers no matter what else they may
1565 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1572 /* Check an intrinsic arithmetic operation to see if it is consistent
1573 with some type of expression. */
1575 static try check_init_expr (gfc_expr
*);
1578 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1580 gfc_expr
*op1
= e
->value
.op
.op1
;
1581 gfc_expr
*op2
= e
->value
.op
.op2
;
1583 if ((*check_function
) (op1
) == FAILURE
)
1586 switch (e
->value
.op
.operator)
1588 case INTRINSIC_UPLUS
:
1589 case INTRINSIC_UMINUS
:
1590 if (!numeric_type (et0 (op1
)))
1600 if ((*check_function
) (op2
) == FAILURE
)
1603 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1604 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1606 gfc_error ("Numeric or CHARACTER operands are required in "
1607 "expression at %L", &e
->where
);
1612 case INTRINSIC_PLUS
:
1613 case INTRINSIC_MINUS
:
1614 case INTRINSIC_TIMES
:
1615 case INTRINSIC_DIVIDE
:
1616 case INTRINSIC_POWER
:
1617 if ((*check_function
) (op2
) == FAILURE
)
1620 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1623 if (e
->value
.op
.operator == INTRINSIC_POWER
1624 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1626 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1627 "exponent in an initialization "
1628 "expression at %L", &op2
->where
)
1635 case INTRINSIC_CONCAT
:
1636 if ((*check_function
) (op2
) == FAILURE
)
1639 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1641 gfc_error ("Concatenation operator in expression at %L "
1642 "must have two CHARACTER operands", &op1
->where
);
1646 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1648 gfc_error ("Concat operator at %L must concatenate strings of the "
1649 "same kind", &e
->where
);
1656 if (et0 (op1
) != BT_LOGICAL
)
1658 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1659 "operand", &op1
->where
);
1668 case INTRINSIC_NEQV
:
1669 if ((*check_function
) (op2
) == FAILURE
)
1672 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1674 gfc_error ("LOGICAL operands are required in expression at %L",
1681 case INTRINSIC_PARENTHESES
:
1685 gfc_error ("Only intrinsic operators can be used in expression at %L",
1693 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1700 /* Certain inquiry functions are specifically allowed to have variable
1701 arguments, which is an exception to the normal requirement that an
1702 initialization function have initialization arguments. We head off
1703 this problem here. */
1706 check_inquiry (gfc_expr
* e
, int not_restricted
)
1710 /* FIXME: This should be moved into the intrinsic definitions,
1711 to eliminate this ugly hack. */
1712 static const char * const inquiry_function
[] = {
1713 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1714 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1715 "lbound", "ubound", NULL
1720 /* An undeclared parameter will get us here (PR25018). */
1721 if (e
->symtree
== NULL
)
1724 name
= e
->symtree
->n
.sym
->name
;
1726 for (i
= 0; inquiry_function
[i
]; i
++)
1727 if (strcmp (inquiry_function
[i
], name
) == 0)
1730 if (inquiry_function
[i
] == NULL
)
1733 e
= e
->value
.function
.actual
->expr
;
1735 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1738 /* At this point we have an inquiry function with a variable argument. The
1739 type of the variable might be undefined, but we need it now, because the
1740 arguments of these functions are allowed to be undefined. */
1742 if (e
->ts
.type
== BT_UNKNOWN
)
1744 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1745 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1749 e
->ts
= e
->symtree
->n
.sym
->ts
;
1752 /* Assumed character length will not reduce to a constant expression
1753 with LEN, as required by the standard. */
1754 if (i
== 4 && not_restricted
1755 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1756 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1757 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1758 "variable '%s' in constant expression at %L",
1759 e
->symtree
->n
.sym
->name
, &e
->where
);
1765 /* Verify that an expression is an initialization expression. A side
1766 effect is that the expression tree is reduced to a single constant
1767 node if all goes well. This would normally happen when the
1768 expression is constructed but function references are assumed to be
1769 intrinsics in the context of initialization expressions. If
1770 FAILURE is returned an error message has been generated. */
1773 check_init_expr (gfc_expr
* e
)
1775 gfc_actual_arglist
*ap
;
1782 switch (e
->expr_type
)
1785 t
= check_intrinsic_op (e
, check_init_expr
);
1787 t
= gfc_simplify_expr (e
, 0);
1794 if (check_inquiry (e
, 1) != SUCCESS
)
1797 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1798 if (check_init_expr (ap
->expr
) == FAILURE
)
1807 m
= gfc_intrinsic_func_interface (e
, 0);
1810 gfc_error ("Function '%s' in initialization expression at %L "
1811 "must be an intrinsic function",
1812 e
->symtree
->n
.sym
->name
, &e
->where
);
1823 if (gfc_check_iter_variable (e
) == SUCCESS
)
1826 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1828 t
= simplify_parameter_variable (e
, 0);
1832 gfc_error ("Parameter '%s' at %L has not been declared or is "
1833 "a variable, which does not reduce to a constant "
1834 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1843 case EXPR_SUBSTRING
:
1844 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1848 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1850 t
= gfc_simplify_expr (e
, 0);
1854 case EXPR_STRUCTURE
:
1855 t
= gfc_check_constructor (e
, check_init_expr
);
1859 t
= gfc_check_constructor (e
, check_init_expr
);
1863 t
= gfc_expand_constructor (e
);
1867 t
= gfc_check_constructor_type (e
);
1871 gfc_internal_error ("check_init_expr(): Unknown expression type");
1878 /* Match an initialization expression. We work by first matching an
1879 expression, then reducing it to a constant. */
1882 gfc_match_init_expr (gfc_expr
** result
)
1888 m
= gfc_match_expr (&expr
);
1893 t
= gfc_resolve_expr (expr
);
1895 t
= check_init_expr (expr
);
1900 gfc_free_expr (expr
);
1904 if (expr
->expr_type
== EXPR_ARRAY
1905 && (gfc_check_constructor_type (expr
) == FAILURE
1906 || gfc_expand_constructor (expr
) == FAILURE
))
1908 gfc_free_expr (expr
);
1912 /* Not all inquiry functions are simplified to constant expressions
1913 so it is necessary to call check_inquiry again. */
1914 if (!gfc_is_constant_expr (expr
)
1915 && check_inquiry (expr
, 1) == FAILURE
)
1917 gfc_error ("Initialization expression didn't reduce %C");
1928 static try check_restricted (gfc_expr
*);
1930 /* Given an actual argument list, test to see that each argument is a
1931 restricted expression and optionally if the expression type is
1932 integer or character. */
1935 restricted_args (gfc_actual_arglist
* a
)
1937 for (; a
; a
= a
->next
)
1939 if (check_restricted (a
->expr
) == FAILURE
)
1947 /************* Restricted/specification expressions *************/
1950 /* Make sure a non-intrinsic function is a specification function. */
1953 external_spec_function (gfc_expr
* e
)
1957 f
= e
->value
.function
.esym
;
1959 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1961 gfc_error ("Specification function '%s' at %L cannot be a statement "
1962 "function", f
->name
, &e
->where
);
1966 if (f
->attr
.proc
== PROC_INTERNAL
)
1968 gfc_error ("Specification function '%s' at %L cannot be an internal "
1969 "function", f
->name
, &e
->where
);
1973 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1975 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1980 if (f
->attr
.recursive
)
1982 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1983 f
->name
, &e
->where
);
1987 return restricted_args (e
->value
.function
.actual
);
1991 /* Check to see that a function reference to an intrinsic is a
1992 restricted expression. */
1995 restricted_intrinsic (gfc_expr
* e
)
1997 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1998 if (check_inquiry (e
, 0) == SUCCESS
)
2001 return restricted_args (e
->value
.function
.actual
);
2005 /* Verify that an expression is a restricted expression. Like its
2006 cousin check_init_expr(), an error message is generated if we
2010 check_restricted (gfc_expr
* e
)
2018 switch (e
->expr_type
)
2021 t
= check_intrinsic_op (e
, check_restricted
);
2023 t
= gfc_simplify_expr (e
, 0);
2028 t
= e
->value
.function
.esym
?
2029 external_spec_function (e
) : restricted_intrinsic (e
);
2034 sym
= e
->symtree
->n
.sym
;
2037 if (sym
->attr
.optional
)
2039 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2040 sym
->name
, &e
->where
);
2044 if (sym
->attr
.intent
== INTENT_OUT
)
2046 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2047 sym
->name
, &e
->where
);
2051 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
2052 in resolve.c(resolve_formal_arglist). This is done so that host associated
2053 dummy array indices are accepted (PR23446). This mechanism also does the
2054 same for the specification expressions of array-valued functions. */
2055 if (sym
->attr
.in_common
2056 || sym
->attr
.use_assoc
2058 || sym
->ns
!= gfc_current_ns
2059 || (sym
->ns
->proc_name
!= NULL
2060 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2061 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2067 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2068 sym
->name
, &e
->where
);
2077 case EXPR_SUBSTRING
:
2078 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2082 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2084 t
= gfc_simplify_expr (e
, 0);
2088 case EXPR_STRUCTURE
:
2089 t
= gfc_check_constructor (e
, check_restricted
);
2093 t
= gfc_check_constructor (e
, check_restricted
);
2097 gfc_internal_error ("check_restricted(): Unknown expression type");
2104 /* Check to see that an expression is a specification expression. If
2105 we return FAILURE, an error has been generated. */
2108 gfc_specification_expr (gfc_expr
* e
)
2113 if (e
->ts
.type
!= BT_INTEGER
)
2115 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2121 gfc_error ("Expression at %L must be scalar", &e
->where
);
2125 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2128 return check_restricted (e
);
2132 /************** Expression conformance checks. *************/
2134 /* Given two expressions, make sure that the arrays are conformable. */
2137 gfc_check_conformance (const char *optype_msgid
,
2138 gfc_expr
* op1
, gfc_expr
* op2
)
2140 int op1_flag
, op2_flag
, d
;
2141 mpz_t op1_size
, op2_size
;
2144 if (op1
->rank
== 0 || op2
->rank
== 0)
2147 if (op1
->rank
!= op2
->rank
)
2149 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2156 for (d
= 0; d
< op1
->rank
; d
++)
2158 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2159 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2161 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2163 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2164 _(optype_msgid
), &op1
->where
, d
+ 1,
2165 (int) mpz_get_si (op1_size
),
2166 (int) mpz_get_si (op2_size
));
2172 mpz_clear (op1_size
);
2174 mpz_clear (op2_size
);
2184 /* Given an assignable expression and an arbitrary expression, make
2185 sure that the assignment can take place. */
2188 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
2192 sym
= lvalue
->symtree
->n
.sym
;
2194 if (sym
->attr
.intent
== INTENT_IN
)
2196 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
2197 sym
->name
, &lvalue
->where
);
2201 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2202 variable local to a function subprogram. Its existence begins when
2203 execution of the function is initiated and ends when execution of the
2204 function is terminated.....
2205 Therefore, the left hand side is no longer a varaiable, when it is:*/
2206 if (sym
->attr
.flavor
== FL_PROCEDURE
2207 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2208 && !sym
->attr
.external
)
2213 /* (i) Use associated; */
2214 if (sym
->attr
.use_assoc
)
2217 /* (ii) The assignment is in the main program; or */
2218 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2221 /* (iii) A module or internal procedure.... */
2222 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2223 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2224 && gfc_current_ns
->parent
2225 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2226 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2227 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2229 /* .... that is not a function.... */
2230 if (!gfc_current_ns
->proc_name
->attr
.function
)
2233 /* .... or is not an entry and has a different name. */
2234 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2240 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2245 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2247 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2248 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2252 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2254 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2259 if (rvalue
->expr_type
== EXPR_NULL
)
2261 gfc_error ("NULL appears on right-hand side in assignment at %L",
2266 if (sym
->attr
.cray_pointee
2267 && lvalue
->ref
!= NULL
2268 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2269 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2271 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
2272 " is illegal", &lvalue
->where
);
2276 /* This is possibly a typo: x = f() instead of x => f() */
2277 if (gfc_option
.warn_surprising
2278 && rvalue
->expr_type
== EXPR_FUNCTION
2279 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2280 gfc_warning ("POINTER valued function appears on right-hand side of "
2281 "assignment at %L", &rvalue
->where
);
2283 /* Check size of array assignments. */
2284 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2285 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2288 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2293 /* Numeric can be converted to any other numeric. And Hollerith can be
2294 converted to any other type. */
2295 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2296 || rvalue
->ts
.type
== BT_HOLLERITH
)
2299 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2302 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2303 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2304 gfc_typename (&lvalue
->ts
));
2309 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2313 /* Check that a pointer assignment is OK. We first check lvalue, and
2314 we only check rvalue if it's not an assignment to NULL() or a
2315 NULLIFY statement. */
2318 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
2320 symbol_attribute attr
;
2323 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2325 gfc_error ("Pointer assignment target is not a POINTER at %L",
2330 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2331 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2333 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2334 "l-value since it is a procedure",
2335 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2339 attr
= gfc_variable_attr (lvalue
, NULL
);
2342 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2346 is_pure
= gfc_pure (NULL
);
2348 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2350 gfc_error ("Bad pointer object in PURE procedure at %L",
2355 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2356 kind, etc for lvalue and rvalue must match, and rvalue must be a
2357 pure variable if we're in a pure function. */
2358 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2361 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2363 gfc_error ("Different types in pointer assignment at %L",
2368 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2370 gfc_error ("Different kind type parameters in pointer "
2371 "assignment at %L", &lvalue
->where
);
2375 if (lvalue
->rank
!= rvalue
->rank
)
2377 gfc_error ("Different ranks in pointer assignment at %L",
2382 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2383 if (rvalue
->expr_type
== EXPR_NULL
)
2386 if (lvalue
->ts
.type
== BT_CHARACTER
2387 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2388 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2389 rvalue
->ts
.cl
->length
)) == 1)
2391 gfc_error ("Different character lengths in pointer "
2392 "assignment at %L", &lvalue
->where
);
2396 attr
= gfc_expr_attr (rvalue
);
2397 if (!attr
.target
&& !attr
.pointer
)
2399 gfc_error ("Pointer assignment target is neither TARGET "
2400 "nor POINTER at %L", &rvalue
->where
);
2404 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2406 gfc_error ("Bad target in pointer assignment in PURE "
2407 "procedure at %L", &rvalue
->where
);
2410 if (gfc_has_vector_index (rvalue
))
2412 gfc_error ("Pointer assignment with vector subscript "
2413 "on rhs at %L", &rvalue
->where
);
2417 if (attr
.protected && attr
.use_assoc
)
2419 gfc_error ("Pointer assigment target has PROTECTED "
2420 "attribute at %L", &rvalue
->where
);
2428 /* Relative of gfc_check_assign() except that the lvalue is a single
2429 symbol. Used for initialization assignments. */
2432 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2437 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2439 lvalue
.expr_type
= EXPR_VARIABLE
;
2440 lvalue
.ts
= sym
->ts
;
2442 lvalue
.rank
= sym
->as
->rank
;
2443 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2444 lvalue
.symtree
->n
.sym
= sym
;
2445 lvalue
.where
= sym
->declared_at
;
2447 if (sym
->attr
.pointer
)
2448 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2450 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2452 gfc_free (lvalue
.symtree
);
2458 /* Get an expression for a default initializer. */
2461 gfc_default_initializer (gfc_typespec
*ts
)
2463 gfc_constructor
*tail
;
2469 /* See if we have a default initializer. */
2470 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2472 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2473 init
= gfc_get_expr ();
2479 /* Build the constructor. */
2480 init
->expr_type
= EXPR_STRUCTURE
;
2482 init
->where
= ts
->derived
->declared_at
;
2484 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2487 init
->value
.constructor
= tail
= gfc_get_constructor ();
2490 tail
->next
= gfc_get_constructor ();
2495 tail
->expr
= gfc_copy_expr (c
->initializer
);
2499 tail
->expr
= gfc_get_expr ();
2500 tail
->expr
->expr_type
= EXPR_NULL
;
2501 tail
->expr
->ts
= c
->ts
;
2508 /* Given a symbol, create an expression node with that symbol as a
2509 variable. If the symbol is array valued, setup a reference of the
2513 gfc_get_variable_expr (gfc_symtree
* var
)
2517 e
= gfc_get_expr ();
2518 e
->expr_type
= EXPR_VARIABLE
;
2520 e
->ts
= var
->n
.sym
->ts
;
2522 if (var
->n
.sym
->as
!= NULL
)
2524 e
->rank
= var
->n
.sym
->as
->rank
;
2525 e
->ref
= gfc_get_ref ();
2526 e
->ref
->type
= REF_ARRAY
;
2527 e
->ref
->u
.ar
.type
= AR_FULL
;
2534 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2537 gfc_expr_set_symbols_referenced (gfc_expr
* expr
)
2539 gfc_actual_arglist
*arg
;
2546 switch (expr
->expr_type
)
2549 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2550 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2554 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2555 gfc_expr_set_symbols_referenced (arg
->expr
);
2559 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2564 case EXPR_SUBSTRING
:
2567 case EXPR_STRUCTURE
:
2569 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2570 gfc_expr_set_symbols_referenced (c
->expr
);
2578 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2582 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2584 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2585 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2586 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2594 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2595 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);