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_ui (tmp_mpz
, tmp_mpz
, one
);
1193 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1194 mpz_add (ptr
, ptr
, tmp_mpz
);
1196 if (!incr_ctr
) continue;
1198 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1200 gcc_assert(vecsub
[d
]);
1202 if (!vecsub
[d
]->next
)
1203 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1206 vecsub
[d
] = vecsub
[d
]->next
;
1209 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1213 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1215 if (mpz_cmp_ui (stride
[d
], 0) > 0 ?
1216 mpz_cmp (ctr
[d
], end
[d
]) > 0 :
1217 mpz_cmp (ctr
[d
], end
[d
]) < 0)
1218 mpz_set (ctr
[d
], start
[d
]);
1224 /* There must be a better way of dealing with negative strides
1225 than resetting the index and the constructor pointer! */
1226 if (mpz_cmp (ptr
, index
) < 0)
1228 mpz_set_ui (index
, 0);
1232 while (mpz_cmp (ptr
, index
) > 0)
1234 mpz_add_ui (index
, index
, one
);
1238 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1246 mpz_clear (delta_mpz
);
1247 mpz_clear (tmp_mpz
);
1249 for (d
= 0; d
< rank
; d
++)
1251 mpz_clear (delta
[d
]);
1252 mpz_clear (start
[d
]);
1255 mpz_clear (stride
[d
]);
1257 gfc_free_constructor (base
);
1261 /* Pull a substring out of an expression. */
1264 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1270 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1271 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1274 *newp
= gfc_copy_expr (p
);
1275 chr
= p
->value
.character
.string
;
1276 end
= (int)mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1277 start
= (int)mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1279 (*newp
)->value
.character
.length
= end
- start
+ 1;
1280 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1281 (*newp
)->value
.character
.length
);
1287 /* Simplify a subobject reference of a constructor. This occurs when
1288 parameter variable values are substituted. */
1291 simplify_const_ref (gfc_expr
* p
)
1293 gfc_constructor
*cons
;
1298 switch (p
->ref
->type
)
1301 switch (p
->ref
->u
.ar
.type
)
1304 if (find_array_element (p
->value
.constructor
,
1312 remove_subobject_ref (p
, cons
);
1316 if (find_array_section (p
, p
->ref
) == FAILURE
)
1318 p
->ref
->u
.ar
.type
= AR_FULL
;
1323 if (p
->ref
->next
!= NULL
1324 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1326 cons
= p
->value
.constructor
;
1327 for (; cons
; cons
= cons
->next
)
1329 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1330 simplify_const_ref (cons
->expr
);
1333 gfc_free_ref_list (p
->ref
);
1344 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1345 remove_subobject_ref (p
, cons
);
1349 if (find_substring_ref (p
, &newp
) == FAILURE
)
1352 gfc_replace_expr (p
, newp
);
1353 gfc_free_ref_list (p
->ref
);
1363 /* Simplify a chain of references. */
1366 simplify_ref_chain (gfc_ref
* ref
, int type
)
1370 for (; ref
; ref
= ref
->next
)
1375 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1377 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1380 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1383 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1391 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1393 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1405 /* Try to substitute the value of a parameter variable. */
1407 simplify_parameter_variable (gfc_expr
* p
, int type
)
1412 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1418 /* Do not copy subobject refs for constant. */
1419 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1420 e
->ref
= copy_ref (p
->ref
);
1421 t
= gfc_simplify_expr (e
, type
);
1423 /* Only use the simplification if it eliminated all subobject
1425 if (t
== SUCCESS
&& ! e
->ref
)
1426 gfc_replace_expr (p
, e
);
1433 /* Given an expression, simplify it by collapsing constant
1434 expressions. Most simplification takes place when the expression
1435 tree is being constructed. If an intrinsic function is simplified
1436 at some point, we get called again to collapse the result against
1439 We work by recursively simplifying expression nodes, simplifying
1440 intrinsic functions where possible, which can lead to further
1441 constant collapsing. If an operator has constant operand(s), we
1442 rip the expression apart, and rebuild it, hoping that it becomes
1445 The expression type is defined for:
1446 0 Basic expression parsing
1447 1 Simplifying array constructors -- will substitute
1449 Returns FAILURE on error, SUCCESS otherwise.
1450 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1453 gfc_simplify_expr (gfc_expr
* p
, int type
)
1455 gfc_actual_arglist
*ap
;
1460 switch (p
->expr_type
)
1467 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1468 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1471 if (p
->value
.function
.isym
!= NULL
1472 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1477 case EXPR_SUBSTRING
:
1478 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1481 if (gfc_is_constant_expr (p
))
1486 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1487 start
--; /* Convert from one-based to zero-based. */
1488 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1489 s
= gfc_getmem (end
- start
+ 2);
1490 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1491 s
[end
-start
+1] = '\0'; /* TODO: C-style string for debugging. */
1492 gfc_free (p
->value
.character
.string
);
1493 p
->value
.character
.string
= s
;
1494 p
->value
.character
.length
= end
- start
;
1495 p
->ts
.cl
= gfc_get_charlen ();
1496 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1497 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1498 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1499 gfc_free_ref_list (p
->ref
);
1501 p
->expr_type
= EXPR_CONSTANT
;
1506 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1511 /* Only substitute array parameter variables if we are in an
1512 initialization expression, or we want a subsection. */
1513 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1514 && (gfc_init_expr
|| p
->ref
1515 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1517 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1524 gfc_simplify_iterator_var (p
);
1527 /* Simplify subcomponent references. */
1528 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1533 case EXPR_STRUCTURE
:
1535 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1538 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1541 if (p
->expr_type
== EXPR_ARRAY
1542 && p
->ref
&& p
->ref
->type
== REF_ARRAY
1543 && p
->ref
->u
.ar
.type
== AR_FULL
)
1544 gfc_expand_constructor (p
);
1546 if (simplify_const_ref (p
) == FAILURE
)
1556 /* Returns the type of an expression with the exception that iterator
1557 variables are automatically integers no matter what else they may
1564 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1571 /* Check an intrinsic arithmetic operation to see if it is consistent
1572 with some type of expression. */
1574 static try check_init_expr (gfc_expr
*);
1577 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1579 gfc_expr
*op1
= e
->value
.op
.op1
;
1580 gfc_expr
*op2
= e
->value
.op
.op2
;
1582 if ((*check_function
) (op1
) == FAILURE
)
1585 switch (e
->value
.op
.operator)
1587 case INTRINSIC_UPLUS
:
1588 case INTRINSIC_UMINUS
:
1589 if (!numeric_type (et0 (op1
)))
1599 if ((*check_function
) (op2
) == FAILURE
)
1602 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1603 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1605 gfc_error ("Numeric or CHARACTER operands are required in "
1606 "expression at %L", &e
->where
);
1611 case INTRINSIC_PLUS
:
1612 case INTRINSIC_MINUS
:
1613 case INTRINSIC_TIMES
:
1614 case INTRINSIC_DIVIDE
:
1615 case INTRINSIC_POWER
:
1616 if ((*check_function
) (op2
) == FAILURE
)
1619 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1622 if (e
->value
.op
.operator == INTRINSIC_POWER
1623 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1625 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1626 "expression", &op2
->where
);
1632 case INTRINSIC_CONCAT
:
1633 if ((*check_function
) (op2
) == FAILURE
)
1636 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1638 gfc_error ("Concatenation operator in expression at %L "
1639 "must have two CHARACTER operands", &op1
->where
);
1643 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1645 gfc_error ("Concat operator at %L must concatenate strings of the "
1646 "same kind", &e
->where
);
1653 if (et0 (op1
) != BT_LOGICAL
)
1655 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1656 "operand", &op1
->where
);
1665 case INTRINSIC_NEQV
:
1666 if ((*check_function
) (op2
) == FAILURE
)
1669 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1671 gfc_error ("LOGICAL operands are required in expression at %L",
1678 case INTRINSIC_PARENTHESES
:
1682 gfc_error ("Only intrinsic operators can be used in expression at %L",
1690 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1697 /* Certain inquiry functions are specifically allowed to have variable
1698 arguments, which is an exception to the normal requirement that an
1699 initialization function have initialization arguments. We head off
1700 this problem here. */
1703 check_inquiry (gfc_expr
* e
, int not_restricted
)
1707 /* FIXME: This should be moved into the intrinsic definitions,
1708 to eliminate this ugly hack. */
1709 static const char * const inquiry_function
[] = {
1710 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1711 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1712 "lbound", "ubound", NULL
1717 /* An undeclared parameter will get us here (PR25018). */
1718 if (e
->symtree
== NULL
)
1721 name
= e
->symtree
->n
.sym
->name
;
1723 for (i
= 0; inquiry_function
[i
]; i
++)
1724 if (strcmp (inquiry_function
[i
], name
) == 0)
1727 if (inquiry_function
[i
] == NULL
)
1730 e
= e
->value
.function
.actual
->expr
;
1732 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1735 /* At this point we have an inquiry function with a variable argument. The
1736 type of the variable might be undefined, but we need it now, because the
1737 arguments of these functions are allowed to be undefined. */
1739 if (e
->ts
.type
== BT_UNKNOWN
)
1741 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1742 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1746 e
->ts
= e
->symtree
->n
.sym
->ts
;
1749 /* Assumed character length will not reduce to a constant expression
1750 with LEN, as required by the standard. */
1751 if (i
== 4 && not_restricted
1752 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1753 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1754 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1755 "variable '%s' in constant expression at %L",
1756 e
->symtree
->n
.sym
->name
, &e
->where
);
1762 /* Verify that an expression is an initialization expression. A side
1763 effect is that the expression tree is reduced to a single constant
1764 node if all goes well. This would normally happen when the
1765 expression is constructed but function references are assumed to be
1766 intrinsics in the context of initialization expressions. If
1767 FAILURE is returned an error message has been generated. */
1770 check_init_expr (gfc_expr
* e
)
1772 gfc_actual_arglist
*ap
;
1779 switch (e
->expr_type
)
1782 t
= check_intrinsic_op (e
, check_init_expr
);
1784 t
= gfc_simplify_expr (e
, 0);
1791 if (check_inquiry (e
, 1) != SUCCESS
)
1794 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1795 if (check_init_expr (ap
->expr
) == FAILURE
)
1804 m
= gfc_intrinsic_func_interface (e
, 0);
1807 gfc_error ("Function '%s' in initialization expression at %L "
1808 "must be an intrinsic function",
1809 e
->symtree
->n
.sym
->name
, &e
->where
);
1820 if (gfc_check_iter_variable (e
) == SUCCESS
)
1823 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1825 t
= simplify_parameter_variable (e
, 0);
1829 gfc_error ("Parameter '%s' at %L has not been declared or is "
1830 "a variable, which does not reduce to a constant "
1831 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1840 case EXPR_SUBSTRING
:
1841 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1845 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1847 t
= gfc_simplify_expr (e
, 0);
1851 case EXPR_STRUCTURE
:
1852 t
= gfc_check_constructor (e
, check_init_expr
);
1856 t
= gfc_check_constructor (e
, check_init_expr
);
1860 t
= gfc_expand_constructor (e
);
1864 t
= gfc_check_constructor_type (e
);
1868 gfc_internal_error ("check_init_expr(): Unknown expression type");
1875 /* Match an initialization expression. We work by first matching an
1876 expression, then reducing it to a constant. */
1879 gfc_match_init_expr (gfc_expr
** result
)
1885 m
= gfc_match_expr (&expr
);
1890 t
= gfc_resolve_expr (expr
);
1892 t
= check_init_expr (expr
);
1897 gfc_free_expr (expr
);
1901 if (expr
->expr_type
== EXPR_ARRAY
1902 && (gfc_check_constructor_type (expr
) == FAILURE
1903 || gfc_expand_constructor (expr
) == FAILURE
))
1905 gfc_free_expr (expr
);
1909 /* Not all inquiry functions are simplified to constant expressions
1910 so it is necessary to call check_inquiry again. */
1911 if (!gfc_is_constant_expr (expr
)
1912 && check_inquiry (expr
, 1) == FAILURE
)
1914 gfc_error ("Initialization expression didn't reduce %C");
1925 static try check_restricted (gfc_expr
*);
1927 /* Given an actual argument list, test to see that each argument is a
1928 restricted expression and optionally if the expression type is
1929 integer or character. */
1932 restricted_args (gfc_actual_arglist
* a
)
1934 for (; a
; a
= a
->next
)
1936 if (check_restricted (a
->expr
) == FAILURE
)
1944 /************* Restricted/specification expressions *************/
1947 /* Make sure a non-intrinsic function is a specification function. */
1950 external_spec_function (gfc_expr
* e
)
1954 f
= e
->value
.function
.esym
;
1956 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1958 gfc_error ("Specification function '%s' at %L cannot be a statement "
1959 "function", f
->name
, &e
->where
);
1963 if (f
->attr
.proc
== PROC_INTERNAL
)
1965 gfc_error ("Specification function '%s' at %L cannot be an internal "
1966 "function", f
->name
, &e
->where
);
1970 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1972 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1977 if (f
->attr
.recursive
)
1979 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1980 f
->name
, &e
->where
);
1984 return restricted_args (e
->value
.function
.actual
);
1988 /* Check to see that a function reference to an intrinsic is a
1989 restricted expression. */
1992 restricted_intrinsic (gfc_expr
* e
)
1994 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1995 if (check_inquiry (e
, 0) == SUCCESS
)
1998 return restricted_args (e
->value
.function
.actual
);
2002 /* Verify that an expression is a restricted expression. Like its
2003 cousin check_init_expr(), an error message is generated if we
2007 check_restricted (gfc_expr
* e
)
2015 switch (e
->expr_type
)
2018 t
= check_intrinsic_op (e
, check_restricted
);
2020 t
= gfc_simplify_expr (e
, 0);
2025 t
= e
->value
.function
.esym
?
2026 external_spec_function (e
) : restricted_intrinsic (e
);
2031 sym
= e
->symtree
->n
.sym
;
2034 if (sym
->attr
.optional
)
2036 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2037 sym
->name
, &e
->where
);
2041 if (sym
->attr
.intent
== INTENT_OUT
)
2043 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2044 sym
->name
, &e
->where
);
2048 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
2049 in resolve.c(resolve_formal_arglist). This is done so that host associated
2050 dummy array indices are accepted (PR23446). */
2051 if (sym
->attr
.in_common
2052 || sym
->attr
.use_assoc
2054 || sym
->ns
!= gfc_current_ns
2055 || (sym
->ns
->proc_name
!= NULL
2056 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2057 || gfc_is_formal_arg ())
2063 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2064 sym
->name
, &e
->where
);
2073 case EXPR_SUBSTRING
:
2074 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2078 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2080 t
= gfc_simplify_expr (e
, 0);
2084 case EXPR_STRUCTURE
:
2085 t
= gfc_check_constructor (e
, check_restricted
);
2089 t
= gfc_check_constructor (e
, check_restricted
);
2093 gfc_internal_error ("check_restricted(): Unknown expression type");
2100 /* Check to see that an expression is a specification expression. If
2101 we return FAILURE, an error has been generated. */
2104 gfc_specification_expr (gfc_expr
* e
)
2109 if (e
->ts
.type
!= BT_INTEGER
)
2111 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2117 gfc_error ("Expression at %L must be scalar", &e
->where
);
2121 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2124 return check_restricted (e
);
2128 /************** Expression conformance checks. *************/
2130 /* Given two expressions, make sure that the arrays are conformable. */
2133 gfc_check_conformance (const char *optype_msgid
,
2134 gfc_expr
* op1
, gfc_expr
* op2
)
2136 int op1_flag
, op2_flag
, d
;
2137 mpz_t op1_size
, op2_size
;
2140 if (op1
->rank
== 0 || op2
->rank
== 0)
2143 if (op1
->rank
!= op2
->rank
)
2145 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2152 for (d
= 0; d
< op1
->rank
; d
++)
2154 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2155 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2157 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2159 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2160 _(optype_msgid
), &op1
->where
, d
+ 1,
2161 (int) mpz_get_si (op1_size
),
2162 (int) mpz_get_si (op2_size
));
2168 mpz_clear (op1_size
);
2170 mpz_clear (op2_size
);
2180 /* Given an assignable expression and an arbitrary expression, make
2181 sure that the assignment can take place. */
2184 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
2188 sym
= lvalue
->symtree
->n
.sym
;
2190 if (sym
->attr
.intent
== INTENT_IN
)
2192 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
2193 sym
->name
, &lvalue
->where
);
2197 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2198 variable local to a function subprogram. Its existence begins when
2199 execution of the function is initiated and ends when execution of the
2200 function is terminated.....
2201 Therefore, the left hand side is no longer a varaiable, when it is:*/
2202 if (sym
->attr
.flavor
== FL_PROCEDURE
2203 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2204 && !sym
->attr
.external
)
2209 /* (i) Use associated; */
2210 if (sym
->attr
.use_assoc
)
2213 /* (ii) The assignment is in the main program; or */
2214 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2217 /* (iii) A module or internal procedure.... */
2218 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2219 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2220 && gfc_current_ns
->parent
2221 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2222 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2223 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2225 /* .... that is not a function.... */
2226 if (!gfc_current_ns
->proc_name
->attr
.function
)
2229 /* .... or is not an entry and has a different name. */
2230 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2236 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2241 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2243 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2244 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2248 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2250 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2255 if (rvalue
->expr_type
== EXPR_NULL
)
2257 gfc_error ("NULL appears on right-hand side in assignment at %L",
2262 if (sym
->attr
.cray_pointee
2263 && lvalue
->ref
!= NULL
2264 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2265 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2267 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
2268 " is illegal", &lvalue
->where
);
2272 /* This is possibly a typo: x = f() instead of x => f() */
2273 if (gfc_option
.warn_surprising
2274 && rvalue
->expr_type
== EXPR_FUNCTION
2275 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2276 gfc_warning ("POINTER valued function appears on right-hand side of "
2277 "assignment at %L", &rvalue
->where
);
2279 /* Check size of array assignments. */
2280 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2281 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2284 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2289 /* Numeric can be converted to any other numeric. And Hollerith can be
2290 converted to any other type. */
2291 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2292 || rvalue
->ts
.type
== BT_HOLLERITH
)
2295 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2298 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2299 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2300 gfc_typename (&lvalue
->ts
));
2305 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2309 /* Check that a pointer assignment is OK. We first check lvalue, and
2310 we only check rvalue if it's not an assignment to NULL() or a
2311 NULLIFY statement. */
2314 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
2316 symbol_attribute attr
;
2319 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2321 gfc_error ("Pointer assignment target is not a POINTER at %L",
2326 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2327 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2329 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2330 "l-value since it is a procedure",
2331 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2335 attr
= gfc_variable_attr (lvalue
, NULL
);
2338 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2342 is_pure
= gfc_pure (NULL
);
2344 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2346 gfc_error ("Bad pointer object in PURE procedure at %L",
2351 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2352 kind, etc for lvalue and rvalue must match, and rvalue must be a
2353 pure variable if we're in a pure function. */
2354 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2357 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2359 gfc_error ("Different types in pointer assignment at %L",
2364 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2366 gfc_error ("Different kind type parameters in pointer "
2367 "assignment at %L", &lvalue
->where
);
2371 if (lvalue
->rank
!= rvalue
->rank
)
2373 gfc_error ("Different ranks in pointer assignment at %L",
2378 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2379 if (rvalue
->expr_type
== EXPR_NULL
)
2382 if (lvalue
->ts
.type
== BT_CHARACTER
2383 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2384 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2385 rvalue
->ts
.cl
->length
)) == 1)
2387 gfc_error ("Different character lengths in pointer "
2388 "assignment at %L", &lvalue
->where
);
2392 attr
= gfc_expr_attr (rvalue
);
2393 if (!attr
.target
&& !attr
.pointer
)
2395 gfc_error ("Pointer assignment target is neither TARGET "
2396 "nor POINTER at %L", &rvalue
->where
);
2400 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2402 gfc_error ("Bad target in pointer assignment in PURE "
2403 "procedure at %L", &rvalue
->where
);
2406 if (gfc_has_vector_index (rvalue
))
2408 gfc_error ("Pointer assignment with vector subscript "
2409 "on rhs at %L", &rvalue
->where
);
2417 /* Relative of gfc_check_assign() except that the lvalue is a single
2418 symbol. Used for initialization assignments. */
2421 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2426 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2428 lvalue
.expr_type
= EXPR_VARIABLE
;
2429 lvalue
.ts
= sym
->ts
;
2431 lvalue
.rank
= sym
->as
->rank
;
2432 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2433 lvalue
.symtree
->n
.sym
= sym
;
2434 lvalue
.where
= sym
->declared_at
;
2436 if (sym
->attr
.pointer
)
2437 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2439 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2441 gfc_free (lvalue
.symtree
);
2447 /* Get an expression for a default initializer. */
2450 gfc_default_initializer (gfc_typespec
*ts
)
2452 gfc_constructor
*tail
;
2458 /* See if we have a default initializer. */
2459 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2461 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2462 init
= gfc_get_expr ();
2468 /* Build the constructor. */
2469 init
->expr_type
= EXPR_STRUCTURE
;
2471 init
->where
= ts
->derived
->declared_at
;
2473 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2476 init
->value
.constructor
= tail
= gfc_get_constructor ();
2479 tail
->next
= gfc_get_constructor ();
2484 tail
->expr
= gfc_copy_expr (c
->initializer
);
2488 tail
->expr
= gfc_get_expr ();
2489 tail
->expr
->expr_type
= EXPR_NULL
;
2490 tail
->expr
->ts
= c
->ts
;
2497 /* Given a symbol, create an expression node with that symbol as a
2498 variable. If the symbol is array valued, setup a reference of the
2502 gfc_get_variable_expr (gfc_symtree
* var
)
2506 e
= gfc_get_expr ();
2507 e
->expr_type
= EXPR_VARIABLE
;
2509 e
->ts
= var
->n
.sym
->ts
;
2511 if (var
->n
.sym
->as
!= NULL
)
2513 e
->rank
= var
->n
.sym
->as
->rank
;
2514 e
->ref
= gfc_get_ref ();
2515 e
->ref
->type
= REF_ARRAY
;
2516 e
->ref
->u
.ar
.type
= AR_FULL
;
2523 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2526 gfc_expr_set_symbols_referenced (gfc_expr
* expr
)
2528 gfc_actual_arglist
*arg
;
2535 switch (expr
->expr_type
)
2538 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2539 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2543 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2544 gfc_expr_set_symbols_referenced (arg
->expr
);
2548 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2553 case EXPR_SUBSTRING
:
2556 case EXPR_STRUCTURE
:
2558 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2559 gfc_expr_set_symbols_referenced (c
->expr
);
2567 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2571 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2573 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2574 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2575 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2583 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2584 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);