1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
167 /* Free the representation, except in character constants where it
168 is the same as value.character.string and thus already freed. */
169 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
170 gfc_free (e
->representation
.string
);
175 if (e
->value
.op
.op1
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op1
);
177 if (e
->value
.op
.op2
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op2
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
244 /* Try to extract an integer constant from the passed expression node.
245 Returns an error message or NULL if the result is set. It is
246 tempting to generate an error and return SUCCESS or FAILURE, but
247 failure is OK for some callers. */
250 gfc_extract_int (gfc_expr
*expr
, int *result
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
297 dest
->u
.ss
= src
->u
.ss
;
298 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
299 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
316 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
317 if (ref
->type
== REF_ARRAY
)
318 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
319 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
349 So, if the original shape array contains R elements
350 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
351 the result contains R-1 elements:
352 { s1 ... sN-1 sN+1 ... sR-1}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p
->value
.character
.length
== 0
454 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
492 default: /* Binary operators. */
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
494 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 /* Real combined with complex. */
677 e
->ts
.type
= BT_COMPLEX
;
678 if (op1
->ts
.kind
> op2
->ts
.kind
)
679 e
->ts
.kind
= op1
->ts
.kind
;
681 e
->ts
.kind
= op2
->ts
.kind
;
682 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
683 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
684 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
685 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
692 /* Function to determine if an expression is constant or not. This
693 function expects that the expression has already been simplified. */
696 gfc_is_constant_expr (gfc_expr
*e
)
699 gfc_actual_arglist
*arg
;
705 switch (e
->expr_type
)
708 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
709 && (e
->value
.op
.op2
== NULL
710 || gfc_is_constant_expr (e
->value
.op
.op2
)));
718 /* Call to intrinsic with at least one argument. */
720 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
722 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
724 if (!gfc_is_constant_expr (arg
->expr
))
738 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
739 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
744 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
745 if (!gfc_is_constant_expr (c
->expr
))
753 rv
= gfc_constant_ac (e
);
757 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
764 /* Try to collapse intrinsic expressions. */
767 simplify_intrinsic_op (gfc_expr
*p
, int type
)
769 gfc_expr
*op1
, *op2
, *result
;
771 if (p
->value
.op
.operator == INTRINSIC_USER
)
774 op1
= p
->value
.op
.op1
;
775 op2
= p
->value
.op
.op2
;
777 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
779 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
782 if (!gfc_is_constant_expr (op1
)
783 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
787 p
->value
.op
.op1
= NULL
;
788 p
->value
.op
.op2
= NULL
;
790 switch (p
->value
.op
.operator)
792 case INTRINSIC_PARENTHESES
:
793 result
= gfc_parentheses (op1
);
796 case INTRINSIC_UPLUS
:
797 result
= gfc_uplus (op1
);
800 case INTRINSIC_UMINUS
:
801 result
= gfc_uminus (op1
);
805 result
= gfc_add (op1
, op2
);
808 case INTRINSIC_MINUS
:
809 result
= gfc_subtract (op1
, op2
);
812 case INTRINSIC_TIMES
:
813 result
= gfc_multiply (op1
, op2
);
816 case INTRINSIC_DIVIDE
:
817 result
= gfc_divide (op1
, op2
);
820 case INTRINSIC_POWER
:
821 result
= gfc_power (op1
, op2
);
824 case INTRINSIC_CONCAT
:
825 result
= gfc_concat (op1
, op2
);
829 result
= gfc_eq (op1
, op2
);
833 result
= gfc_ne (op1
, op2
);
837 result
= gfc_gt (op1
, op2
);
841 result
= gfc_ge (op1
, op2
);
845 result
= gfc_lt (op1
, op2
);
849 result
= gfc_le (op1
, op2
);
853 result
= gfc_not (op1
);
857 result
= gfc_and (op1
, op2
);
861 result
= gfc_or (op1
, op2
);
865 result
= gfc_eqv (op1
, op2
);
869 result
= gfc_neqv (op1
, op2
);
873 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
883 result
->rank
= p
->rank
;
884 result
->where
= p
->where
;
885 gfc_replace_expr (p
, result
);
891 /* Subroutine to simplify constructor expressions. Mutually recursive
892 with gfc_simplify_expr(). */
895 simplify_constructor (gfc_constructor
*c
, int type
)
897 for (; c
; c
= c
->next
)
900 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
901 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
902 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
905 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
913 /* Pull a single array element out of an array constructor. */
916 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
917 gfc_constructor
**rval
)
919 unsigned long nelemen
;
931 mpz_init_set_ui (offset
, 0);
934 mpz_init_set_ui (span
, 1);
935 for (i
= 0; i
< ar
->dimen
; i
++)
937 e
= gfc_copy_expr (ar
->start
[i
]);
938 if (e
->expr_type
!= EXPR_CONSTANT
)
944 /* Check the bounds. */
946 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
947 || mpz_cmp (e
->value
.integer
,
948 ar
->as
->lower
[i
]->value
.integer
) < 0))
950 gfc_error ("index in dimension %d is out of bounds "
951 "at %L", i
+ 1, &ar
->c_where
[i
]);
957 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
958 mpz_mul (delta
, delta
, span
);
959 mpz_add (offset
, offset
, delta
);
962 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
963 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
964 mpz_mul (span
, span
, tmp
);
969 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
992 /* Find a component of a structure constructor. */
994 static gfc_constructor
*
995 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1000 comp
= ref
->u
.c
.sym
->components
;
1001 pick
= ref
->u
.c
.component
;
1002 while (comp
!= pick
)
1012 /* Replace an expression with the contents of a constructor, removing
1013 the subobject reference in the process. */
1016 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1022 e
->ref
= p
->ref
->next
;
1023 p
->ref
->next
= NULL
;
1024 gfc_replace_expr (p
, e
);
1028 /* Pull an array section out of an array constructor. */
1031 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1037 long unsigned one
= 1;
1039 mpz_t start
[GFC_MAX_DIMENSIONS
];
1040 mpz_t end
[GFC_MAX_DIMENSIONS
];
1041 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1042 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1043 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1049 gfc_constructor
*cons
;
1050 gfc_constructor
*base
;
1056 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1061 base
= expr
->value
.constructor
;
1062 expr
->value
.constructor
= NULL
;
1064 rank
= ref
->u
.ar
.as
->rank
;
1066 if (expr
->shape
== NULL
)
1067 expr
->shape
= gfc_get_shape (rank
);
1069 mpz_init_set_ui (delta_mpz
, one
);
1070 mpz_init_set_ui (nelts
, one
);
1073 /* Do the initialization now, so that we can cleanup without
1074 keeping track of where we were. */
1075 for (d
= 0; d
< rank
; d
++)
1077 mpz_init (delta
[d
]);
1078 mpz_init (start
[d
]);
1081 mpz_init (stride
[d
]);
1085 /* Build the counters to clock through the array reference. */
1087 for (d
= 0; d
< rank
; d
++)
1089 /* Make this stretch of code easier on the eye! */
1090 begin
= ref
->u
.ar
.start
[d
];
1091 finish
= ref
->u
.ar
.end
[d
];
1092 step
= ref
->u
.ar
.stride
[d
];
1093 lower
= ref
->u
.ar
.as
->lower
[d
];
1094 upper
= ref
->u
.ar
.as
->upper
[d
];
1096 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1100 if (begin
->expr_type
!= EXPR_ARRAY
)
1106 gcc_assert (begin
->rank
== 1);
1107 gcc_assert (begin
->shape
);
1109 vecsub
[d
] = begin
->value
.constructor
;
1110 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1111 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1112 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1115 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1117 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1118 || mpz_cmp (c
->expr
->value
.integer
,
1119 lower
->value
.integer
) < 0)
1121 gfc_error ("index in dimension %d is out of bounds "
1122 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1130 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1131 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1132 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1138 /* Obtain the stride. */
1140 mpz_set (stride
[d
], step
->value
.integer
);
1142 mpz_set_ui (stride
[d
], one
);
1144 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1145 mpz_set_ui (stride
[d
], one
);
1147 /* Obtain the start value for the index. */
1149 mpz_set (start
[d
], begin
->value
.integer
);
1151 mpz_set (start
[d
], lower
->value
.integer
);
1153 mpz_set (ctr
[d
], start
[d
]);
1155 /* Obtain the end value for the index. */
1157 mpz_set (end
[d
], finish
->value
.integer
);
1159 mpz_set (end
[d
], upper
->value
.integer
);
1161 /* Separate 'if' because elements sometimes arrive with
1163 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1164 mpz_set (end
[d
], begin
->value
.integer
);
1166 /* Check the bounds. */
1167 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1168 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1169 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1170 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1172 gfc_error ("index in dimension %d is out of bounds "
1173 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1178 /* Calculate the number of elements and the shape. */
1179 mpz_set (tmp_mpz
, stride
[d
]);
1180 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1181 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1182 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1183 mpz_mul (nelts
, nelts
, tmp_mpz
);
1185 /* An element reference reduces the rank of the expression; don't
1186 add anything to the shape array. */
1187 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1188 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1191 /* Calculate the 'stride' (=delta) for conversion of the
1192 counter values into the index along the constructor. */
1193 mpz_set (delta
[d
], delta_mpz
);
1194 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1195 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1196 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1203 /* Now clock through the array reference, calculating the index in
1204 the source constructor and transferring the elements to the new
1206 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1208 if (ref
->u
.ar
.offset
)
1209 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1211 mpz_init_set_ui (ptr
, 0);
1214 for (d
= 0; d
< rank
; d
++)
1216 mpz_set (tmp_mpz
, ctr
[d
]);
1217 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1218 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1219 mpz_add (ptr
, ptr
, tmp_mpz
);
1221 if (!incr_ctr
) continue;
1223 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1225 gcc_assert(vecsub
[d
]);
1227 if (!vecsub
[d
]->next
)
1228 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1231 vecsub
[d
] = vecsub
[d
]->next
;
1234 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1238 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1240 if (mpz_cmp_ui (stride
[d
], 0) > 0
1241 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1242 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1243 mpz_set (ctr
[d
], start
[d
]);
1249 /* There must be a better way of dealing with negative strides
1250 than resetting the index and the constructor pointer! */
1251 if (mpz_cmp (ptr
, index
) < 0)
1253 mpz_set_ui (index
, 0);
1257 while (mpz_cmp (ptr
, index
) > 0)
1259 mpz_add_ui (index
, index
, one
);
1263 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1271 mpz_clear (delta_mpz
);
1272 mpz_clear (tmp_mpz
);
1274 for (d
= 0; d
< rank
; d
++)
1276 mpz_clear (delta
[d
]);
1277 mpz_clear (start
[d
]);
1280 mpz_clear (stride
[d
]);
1282 gfc_free_constructor (base
);
1286 /* Pull a substring out of an expression. */
1289 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1295 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1296 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1299 *newp
= gfc_copy_expr (p
);
1300 chr
= p
->value
.character
.string
;
1301 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1302 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1304 (*newp
)->value
.character
.length
= end
- start
+ 1;
1305 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1306 (*newp
)->value
.character
.length
);
1312 /* Simplify a subobject reference of a constructor. This occurs when
1313 parameter variable values are substituted. */
1316 simplify_const_ref (gfc_expr
*p
)
1318 gfc_constructor
*cons
;
1323 switch (p
->ref
->type
)
1326 switch (p
->ref
->u
.ar
.type
)
1329 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1336 remove_subobject_ref (p
, cons
);
1340 if (find_array_section (p
, p
->ref
) == FAILURE
)
1342 p
->ref
->u
.ar
.type
= AR_FULL
;
1347 if (p
->ref
->next
!= NULL
1348 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1350 cons
= p
->value
.constructor
;
1351 for (; cons
; cons
= cons
->next
)
1353 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1354 simplify_const_ref (cons
->expr
);
1357 gfc_free_ref_list (p
->ref
);
1368 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1369 remove_subobject_ref (p
, cons
);
1373 if (find_substring_ref (p
, &newp
) == FAILURE
)
1376 gfc_replace_expr (p
, newp
);
1377 gfc_free_ref_list (p
->ref
);
1387 /* Simplify a chain of references. */
1390 simplify_ref_chain (gfc_ref
*ref
, int type
)
1394 for (; ref
; ref
= ref
->next
)
1399 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1401 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1403 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1405 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1411 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1413 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1425 /* Try to substitute the value of a parameter variable. */
1428 simplify_parameter_variable (gfc_expr
*p
, int type
)
1433 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1439 /* Do not copy subobject refs for constant. */
1440 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1441 e
->ref
= copy_ref (p
->ref
);
1442 t
= gfc_simplify_expr (e
, type
);
1444 /* Only use the simplification if it eliminated all subobject references. */
1445 if (t
== SUCCESS
&& !e
->ref
)
1446 gfc_replace_expr (p
, e
);
1453 /* Given an expression, simplify it by collapsing constant
1454 expressions. Most simplification takes place when the expression
1455 tree is being constructed. If an intrinsic function is simplified
1456 at some point, we get called again to collapse the result against
1459 We work by recursively simplifying expression nodes, simplifying
1460 intrinsic functions where possible, which can lead to further
1461 constant collapsing. If an operator has constant operand(s), we
1462 rip the expression apart, and rebuild it, hoping that it becomes
1465 The expression type is defined for:
1466 0 Basic expression parsing
1467 1 Simplifying array constructors -- will substitute
1469 Returns FAILURE on error, SUCCESS otherwise.
1470 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1473 gfc_simplify_expr (gfc_expr
*p
, int type
)
1475 gfc_actual_arglist
*ap
;
1480 switch (p
->expr_type
)
1487 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1488 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1491 if (p
->value
.function
.isym
!= NULL
1492 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1497 case EXPR_SUBSTRING
:
1498 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1501 if (gfc_is_constant_expr (p
))
1506 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1507 start
--; /* Convert from one-based to zero-based. */
1508 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1509 s
= gfc_getmem (end
- start
+ 2);
1510 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1511 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1512 gfc_free (p
->value
.character
.string
);
1513 p
->value
.character
.string
= s
;
1514 p
->value
.character
.length
= end
- start
;
1515 p
->ts
.cl
= gfc_get_charlen ();
1516 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1517 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1518 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1519 gfc_free_ref_list (p
->ref
);
1521 p
->expr_type
= EXPR_CONSTANT
;
1526 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1531 /* Only substitute array parameter variables if we are in an
1532 initialization expression, or we want a subsection. */
1533 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1534 && (gfc_init_expr
|| p
->ref
1535 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1537 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1544 gfc_simplify_iterator_var (p
);
1547 /* Simplify subcomponent references. */
1548 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1553 case EXPR_STRUCTURE
:
1555 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1558 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1561 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1562 && p
->ref
->u
.ar
.type
== AR_FULL
)
1563 gfc_expand_constructor (p
);
1565 if (simplify_const_ref (p
) == FAILURE
)
1575 /* Returns the type of an expression with the exception that iterator
1576 variables are automatically integers no matter what else they may
1582 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1589 /* Check an intrinsic arithmetic operation to see if it is consistent
1590 with some type of expression. */
1592 static try check_init_expr (gfc_expr
*);
1595 /* Scalarize an expression for an elemental intrinsic call. */
1598 scalarize_intrinsic_call (gfc_expr
*e
)
1600 gfc_actual_arglist
*a
, *b
;
1601 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1602 gfc_expr
*expr
, *old
;
1605 old
= gfc_copy_expr (e
);
1607 /* Assume that the old expression carries the type information and
1608 that the first arg carries all the shape information. */
1609 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1610 gfc_free_constructor (expr
->value
.constructor
);
1611 expr
->value
.constructor
= NULL
;
1614 expr
->expr_type
= EXPR_ARRAY
;
1616 /* Copy the array argument constructors into an array, with nulls
1619 a
= old
->value
.function
.actual
;
1620 for (; a
; a
= a
->next
)
1622 /* Check that this is OK for an initialization expression. */
1623 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1627 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1629 rank
[n
] = a
->expr
->rank
;
1630 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1631 args
[n
] = gfc_copy_constructor (ctor
);
1633 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1636 rank
[n
] = a
->expr
->rank
;
1639 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1646 for (i
= 1; i
< n
; i
++)
1647 if (rank
[i
] && rank
[i
] != rank
[0])
1650 /* Using the first argument as the master, step through the array
1651 calling the function for each element and advancing the array
1652 constructors together. */
1655 for (; ctor
; ctor
= ctor
->next
)
1657 if (expr
->value
.constructor
== NULL
)
1658 expr
->value
.constructor
1659 = new_ctor
= gfc_get_constructor ();
1662 new_ctor
->next
= gfc_get_constructor ();
1663 new_ctor
= new_ctor
->next
;
1665 new_ctor
->expr
= gfc_copy_expr (old
);
1666 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1668 b
= old
->value
.function
.actual
;
1669 for (i
= 0; i
< n
; i
++)
1672 new_ctor
->expr
->value
.function
.actual
1673 = a
= gfc_get_actual_arglist ();
1676 a
->next
= gfc_get_actual_arglist ();
1680 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1682 a
->expr
= gfc_copy_expr (b
->expr
);
1687 /* Simplify the function calls. */
1688 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1691 for (i
= 0; i
< n
; i
++)
1693 args
[i
] = args
[i
]->next
;
1695 for (i
= 1; i
< n
; i
++)
1696 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1697 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1703 gfc_free_expr (old
);
1707 gfc_error_now ("elemental function arguments at %C are not compliant");
1710 gfc_free_expr (expr
);
1711 gfc_free_expr (old
);
1717 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1719 gfc_expr
*op1
= e
->value
.op
.op1
;
1720 gfc_expr
*op2
= e
->value
.op
.op2
;
1722 if ((*check_function
) (op1
) == FAILURE
)
1725 switch (e
->value
.op
.operator)
1727 case INTRINSIC_UPLUS
:
1728 case INTRINSIC_UMINUS
:
1729 if (!numeric_type (et0 (op1
)))
1739 if ((*check_function
) (op2
) == FAILURE
)
1742 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1743 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1745 gfc_error ("Numeric or CHARACTER operands are required in "
1746 "expression at %L", &e
->where
);
1751 case INTRINSIC_PLUS
:
1752 case INTRINSIC_MINUS
:
1753 case INTRINSIC_TIMES
:
1754 case INTRINSIC_DIVIDE
:
1755 case INTRINSIC_POWER
:
1756 if ((*check_function
) (op2
) == FAILURE
)
1759 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1762 if (e
->value
.op
.operator == INTRINSIC_POWER
1763 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1765 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1766 "exponent in an initialization "
1767 "expression at %L", &op2
->where
)
1774 case INTRINSIC_CONCAT
:
1775 if ((*check_function
) (op2
) == FAILURE
)
1778 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1780 gfc_error ("Concatenation operator in expression at %L "
1781 "must have two CHARACTER operands", &op1
->where
);
1785 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1787 gfc_error ("Concat operator at %L must concatenate strings of the "
1788 "same kind", &e
->where
);
1795 if (et0 (op1
) != BT_LOGICAL
)
1797 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1798 "operand", &op1
->where
);
1807 case INTRINSIC_NEQV
:
1808 if ((*check_function
) (op2
) == FAILURE
)
1811 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1813 gfc_error ("LOGICAL operands are required in expression at %L",
1820 case INTRINSIC_PARENTHESES
:
1824 gfc_error ("Only intrinsic operators can be used in expression at %L",
1832 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1839 /* Certain inquiry functions are specifically allowed to have variable
1840 arguments, which is an exception to the normal requirement that an
1841 initialization function have initialization arguments. We head off
1842 this problem here. */
1845 check_inquiry (gfc_expr
*e
, int not_restricted
)
1849 /* FIXME: This should be moved into the intrinsic definitions,
1850 to eliminate this ugly hack. */
1851 static const char * const inquiry_function
[] = {
1852 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1853 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1854 "lbound", "ubound", NULL
1859 /* An undeclared parameter will get us here (PR25018). */
1860 if (e
->symtree
== NULL
)
1863 name
= e
->symtree
->n
.sym
->name
;
1865 for (i
= 0; inquiry_function
[i
]; i
++)
1866 if (strcmp (inquiry_function
[i
], name
) == 0)
1869 if (inquiry_function
[i
] == NULL
)
1872 e
= e
->value
.function
.actual
->expr
;
1874 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1877 /* At this point we have an inquiry function with a variable argument. The
1878 type of the variable might be undefined, but we need it now, because the
1879 arguments of these functions are allowed to be undefined. */
1881 if (e
->ts
.type
== BT_UNKNOWN
)
1883 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1884 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1888 e
->ts
= e
->symtree
->n
.sym
->ts
;
1891 /* Assumed character length will not reduce to a constant expression
1892 with LEN, as required by the standard. */
1893 if (i
== 4 && not_restricted
1894 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1895 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1896 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1897 "variable '%s' in constant expression at %L",
1898 e
->symtree
->n
.sym
->name
, &e
->where
);
1904 /* Verify that an expression is an initialization expression. A side
1905 effect is that the expression tree is reduced to a single constant
1906 node if all goes well. This would normally happen when the
1907 expression is constructed but function references are assumed to be
1908 intrinsics in the context of initialization expressions. If
1909 FAILURE is returned an error message has been generated. */
1912 check_init_expr (gfc_expr
*e
)
1914 gfc_actual_arglist
*ap
;
1917 gfc_intrinsic_sym
*isym
;
1922 switch (e
->expr_type
)
1925 t
= check_intrinsic_op (e
, check_init_expr
);
1927 t
= gfc_simplify_expr (e
, 0);
1934 if (check_inquiry (e
, 1) != SUCCESS
)
1937 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1938 if (check_init_expr (ap
->expr
) == FAILURE
)
1945 /* Try to scalarize an elemental intrinsic function that has an
1947 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
1948 if (isym
&& isym
->elemental
1949 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
1951 if (scalarize_intrinsic_call (e
) == SUCCESS
)
1957 m
= gfc_intrinsic_func_interface (e
, 0);
1960 gfc_error ("Function '%s' in initialization expression at %L "
1961 "must be an intrinsic function",
1962 e
->symtree
->n
.sym
->name
, &e
->where
);
1973 if (gfc_check_iter_variable (e
) == SUCCESS
)
1976 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1978 t
= simplify_parameter_variable (e
, 0);
1982 if (gfc_in_match_data ())
1985 gfc_error ("Parameter '%s' at %L has not been declared or is "
1986 "a variable, which does not reduce to a constant "
1987 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1996 case EXPR_SUBSTRING
:
1997 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2001 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2003 t
= gfc_simplify_expr (e
, 0);
2007 case EXPR_STRUCTURE
:
2008 t
= gfc_check_constructor (e
, check_init_expr
);
2012 t
= gfc_check_constructor (e
, check_init_expr
);
2016 t
= gfc_expand_constructor (e
);
2020 t
= gfc_check_constructor_type (e
);
2024 gfc_internal_error ("check_init_expr(): Unknown expression type");
2031 /* Match an initialization expression. We work by first matching an
2032 expression, then reducing it to a constant. */
2035 gfc_match_init_expr (gfc_expr
**result
)
2041 m
= gfc_match_expr (&expr
);
2046 t
= gfc_resolve_expr (expr
);
2048 t
= check_init_expr (expr
);
2053 gfc_free_expr (expr
);
2057 if (expr
->expr_type
== EXPR_ARRAY
2058 && (gfc_check_constructor_type (expr
) == FAILURE
2059 || gfc_expand_constructor (expr
) == FAILURE
))
2061 gfc_free_expr (expr
);
2065 /* Not all inquiry functions are simplified to constant expressions
2066 so it is necessary to call check_inquiry again. */
2067 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
2068 && !gfc_in_match_data ())
2070 gfc_error ("Initialization expression didn't reduce %C");
2080 static try check_restricted (gfc_expr
*);
2082 /* Given an actual argument list, test to see that each argument is a
2083 restricted expression and optionally if the expression type is
2084 integer or character. */
2087 restricted_args (gfc_actual_arglist
*a
)
2089 for (; a
; a
= a
->next
)
2091 if (check_restricted (a
->expr
) == FAILURE
)
2099 /************* Restricted/specification expressions *************/
2102 /* Make sure a non-intrinsic function is a specification function. */
2105 external_spec_function (gfc_expr
*e
)
2109 f
= e
->value
.function
.esym
;
2111 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2113 gfc_error ("Specification function '%s' at %L cannot be a statement "
2114 "function", f
->name
, &e
->where
);
2118 if (f
->attr
.proc
== PROC_INTERNAL
)
2120 gfc_error ("Specification function '%s' at %L cannot be an internal "
2121 "function", f
->name
, &e
->where
);
2125 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2127 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2132 if (f
->attr
.recursive
)
2134 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2135 f
->name
, &e
->where
);
2139 return restricted_args (e
->value
.function
.actual
);
2143 /* Check to see that a function reference to an intrinsic is a
2144 restricted expression. */
2147 restricted_intrinsic (gfc_expr
*e
)
2149 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2150 if (check_inquiry (e
, 0) == SUCCESS
)
2153 return restricted_args (e
->value
.function
.actual
);
2157 /* Verify that an expression is a restricted expression. Like its
2158 cousin check_init_expr(), an error message is generated if we
2162 check_restricted (gfc_expr
*e
)
2170 switch (e
->expr_type
)
2173 t
= check_intrinsic_op (e
, check_restricted
);
2175 t
= gfc_simplify_expr (e
, 0);
2180 t
= e
->value
.function
.esym
? external_spec_function (e
)
2181 : restricted_intrinsic (e
);
2185 sym
= e
->symtree
->n
.sym
;
2188 if (sym
->attr
.optional
)
2190 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2191 sym
->name
, &e
->where
);
2195 if (sym
->attr
.intent
== INTENT_OUT
)
2197 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2198 sym
->name
, &e
->where
);
2202 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2203 processed in resolve.c(resolve_formal_arglist). This is done so
2204 that host associated dummy array indices are accepted (PR23446).
2205 This mechanism also does the same for the specification expressions
2206 of array-valued functions. */
2207 if (sym
->attr
.in_common
2208 || sym
->attr
.use_assoc
2210 || sym
->ns
!= gfc_current_ns
2211 || (sym
->ns
->proc_name
!= NULL
2212 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2213 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2219 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2220 sym
->name
, &e
->where
);
2229 case EXPR_SUBSTRING
:
2230 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2234 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2236 t
= gfc_simplify_expr (e
, 0);
2240 case EXPR_STRUCTURE
:
2241 t
= gfc_check_constructor (e
, check_restricted
);
2245 t
= gfc_check_constructor (e
, check_restricted
);
2249 gfc_internal_error ("check_restricted(): Unknown expression type");
2256 /* Check to see that an expression is a specification expression. If
2257 we return FAILURE, an error has been generated. */
2260 gfc_specification_expr (gfc_expr
*e
)
2266 if (e
->ts
.type
!= BT_INTEGER
)
2268 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2274 gfc_error ("Expression at %L must be scalar", &e
->where
);
2278 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2281 return check_restricted (e
);
2285 /************** Expression conformance checks. *************/
2287 /* Given two expressions, make sure that the arrays are conformable. */
2290 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2292 int op1_flag
, op2_flag
, d
;
2293 mpz_t op1_size
, op2_size
;
2296 if (op1
->rank
== 0 || op2
->rank
== 0)
2299 if (op1
->rank
!= op2
->rank
)
2301 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2308 for (d
= 0; d
< op1
->rank
; d
++)
2310 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2311 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2313 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2315 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2316 _(optype_msgid
), &op1
->where
, d
+ 1,
2317 (int) mpz_get_si (op1_size
),
2318 (int) mpz_get_si (op2_size
));
2324 mpz_clear (op1_size
);
2326 mpz_clear (op2_size
);
2336 /* Given an assignable expression and an arbitrary expression, make
2337 sure that the assignment can take place. */
2340 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2346 sym
= lvalue
->symtree
->n
.sym
;
2348 /* Check INTENT(IN), unless the object itself is the component or
2349 sub-component of a pointer. */
2350 has_pointer
= sym
->attr
.pointer
;
2352 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2353 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2359 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2361 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2362 sym
->name
, &lvalue
->where
);
2366 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2367 variable local to a function subprogram. Its existence begins when
2368 execution of the function is initiated and ends when execution of the
2369 function is terminated...
2370 Therefore, the left hand side is no longer a variable, when it is: */
2371 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2372 && !sym
->attr
.external
)
2377 /* (i) Use associated; */
2378 if (sym
->attr
.use_assoc
)
2381 /* (ii) The assignment is in the main program; or */
2382 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2385 /* (iii) A module or internal procedure... */
2386 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2387 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2388 && gfc_current_ns
->parent
2389 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2390 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2391 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2393 /* ... that is not a function... */
2394 if (!gfc_current_ns
->proc_name
->attr
.function
)
2397 /* ... or is not an entry and has a different name. */
2398 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2404 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2409 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2411 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2412 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2416 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2418 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2423 if (rvalue
->expr_type
== EXPR_NULL
)
2425 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2426 && lvalue
->symtree
->n
.sym
->attr
.data
)
2430 gfc_error ("NULL appears on right-hand side in assignment at %L",
2436 if (sym
->attr
.cray_pointee
2437 && lvalue
->ref
!= NULL
2438 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2439 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2441 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2442 "is illegal", &lvalue
->where
);
2446 /* This is possibly a typo: x = f() instead of x => f(). */
2447 if (gfc_option
.warn_surprising
2448 && rvalue
->expr_type
== EXPR_FUNCTION
2449 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2450 gfc_warning ("POINTER valued function appears on right-hand side of "
2451 "assignment at %L", &rvalue
->where
);
2453 /* Check size of array assignments. */
2454 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2455 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2458 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2463 /* Numeric can be converted to any other numeric. And Hollerith can be
2464 converted to any other type. */
2465 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2466 || rvalue
->ts
.type
== BT_HOLLERITH
)
2469 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2472 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2473 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2474 gfc_typename (&lvalue
->ts
));
2479 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2483 /* Check that a pointer assignment is OK. We first check lvalue, and
2484 we only check rvalue if it's not an assignment to NULL() or a
2485 NULLIFY statement. */
2488 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2490 symbol_attribute attr
;
2493 int pointer
, check_intent_in
;
2495 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2497 gfc_error ("Pointer assignment target is not a POINTER at %L",
2502 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2503 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2505 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2506 "l-value since it is a procedure",
2507 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2512 /* Check INTENT(IN), unless the object itself is the component or
2513 sub-component of a pointer. */
2514 check_intent_in
= 1;
2515 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2517 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2520 check_intent_in
= 0;
2522 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2526 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2528 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2529 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2535 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2539 is_pure
= gfc_pure (NULL
);
2541 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2543 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2547 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2548 kind, etc for lvalue and rvalue must match, and rvalue must be a
2549 pure variable if we're in a pure function. */
2550 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2553 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2555 gfc_error ("Different types in pointer assignment at %L",
2560 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2562 gfc_error ("Different kind type parameters in pointer "
2563 "assignment at %L", &lvalue
->where
);
2567 if (lvalue
->rank
!= rvalue
->rank
)
2569 gfc_error ("Different ranks in pointer assignment at %L",
2574 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2575 if (rvalue
->expr_type
== EXPR_NULL
)
2578 if (lvalue
->ts
.type
== BT_CHARACTER
2579 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2580 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2581 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2582 rvalue
->ts
.cl
->length
)) == 1)
2584 gfc_error ("Different character lengths in pointer "
2585 "assignment at %L", &lvalue
->where
);
2589 attr
= gfc_expr_attr (rvalue
);
2590 if (!attr
.target
&& !attr
.pointer
)
2592 gfc_error ("Pointer assignment target is neither TARGET "
2593 "nor POINTER at %L", &rvalue
->where
);
2597 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2599 gfc_error ("Bad target in pointer assignment in PURE "
2600 "procedure at %L", &rvalue
->where
);
2603 if (gfc_has_vector_index (rvalue
))
2605 gfc_error ("Pointer assignment with vector subscript "
2606 "on rhs at %L", &rvalue
->where
);
2610 if (attr
.protected && attr
.use_assoc
)
2612 gfc_error ("Pointer assigment target has PROTECTED "
2613 "attribute at %L", &rvalue
->where
);
2621 /* Relative of gfc_check_assign() except that the lvalue is a single
2622 symbol. Used for initialization assignments. */
2625 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2630 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2632 lvalue
.expr_type
= EXPR_VARIABLE
;
2633 lvalue
.ts
= sym
->ts
;
2635 lvalue
.rank
= sym
->as
->rank
;
2636 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2637 lvalue
.symtree
->n
.sym
= sym
;
2638 lvalue
.where
= sym
->declared_at
;
2640 if (sym
->attr
.pointer
)
2641 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2643 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2645 gfc_free (lvalue
.symtree
);
2651 /* Get an expression for a default initializer. */
2654 gfc_default_initializer (gfc_typespec
*ts
)
2656 gfc_constructor
*tail
;
2662 /* See if we have a default initializer. */
2663 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2665 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2666 init
= gfc_get_expr ();
2672 /* Build the constructor. */
2673 init
->expr_type
= EXPR_STRUCTURE
;
2675 init
->where
= ts
->derived
->declared_at
;
2677 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2680 init
->value
.constructor
= tail
= gfc_get_constructor ();
2683 tail
->next
= gfc_get_constructor ();
2688 tail
->expr
= gfc_copy_expr (c
->initializer
);
2692 tail
->expr
= gfc_get_expr ();
2693 tail
->expr
->expr_type
= EXPR_NULL
;
2694 tail
->expr
->ts
= c
->ts
;
2701 /* Given a symbol, create an expression node with that symbol as a
2702 variable. If the symbol is array valued, setup a reference of the
2706 gfc_get_variable_expr (gfc_symtree
*var
)
2710 e
= gfc_get_expr ();
2711 e
->expr_type
= EXPR_VARIABLE
;
2713 e
->ts
= var
->n
.sym
->ts
;
2715 if (var
->n
.sym
->as
!= NULL
)
2717 e
->rank
= var
->n
.sym
->as
->rank
;
2718 e
->ref
= gfc_get_ref ();
2719 e
->ref
->type
= REF_ARRAY
;
2720 e
->ref
->u
.ar
.type
= AR_FULL
;
2727 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2730 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2732 gfc_actual_arglist
*arg
;
2739 switch (expr
->expr_type
)
2742 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2743 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2747 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2748 gfc_expr_set_symbols_referenced (arg
->expr
);
2752 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2757 case EXPR_SUBSTRING
:
2760 case EXPR_STRUCTURE
:
2762 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2763 gfc_expr_set_symbols_referenced (c
->expr
);
2771 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2775 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2777 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2778 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2779 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2787 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2788 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);