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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 /* Get a new expr node. */
35 e
= gfc_getmem (sizeof (gfc_expr
));
36 gfc_clear_ts (&e
->ts
);
40 e
->con_by_offset
= NULL
;
45 /* Free an argument list and everything below it. */
48 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
50 gfc_actual_arglist
*a2
;
55 gfc_free_expr (a1
->expr
);
62 /* Copy an arglist structure and all of the arguments. */
65 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
67 gfc_actual_arglist
*head
, *tail
, *new;
71 for (; p
; p
= p
->next
)
73 new = gfc_get_actual_arglist ();
76 new->expr
= gfc_copy_expr (p
->expr
);
91 /* Free a list of reference structures. */
94 gfc_free_ref_list (gfc_ref
*p
)
106 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
108 gfc_free_expr (p
->u
.ar
.start
[i
]);
109 gfc_free_expr (p
->u
.ar
.end
[i
]);
110 gfc_free_expr (p
->u
.ar
.stride
[i
]);
116 gfc_free_expr (p
->u
.ss
.start
);
117 gfc_free_expr (p
->u
.ss
.end
);
129 /* Workhorse function for gfc_free_expr() that frees everything
130 beneath an expression node, but not the node itself. This is
131 useful when we want to simplify a node and replace it with
132 something else or the expression node belongs to another structure. */
135 free_expr0 (gfc_expr
*e
)
139 switch (e
->expr_type
)
142 /* Free any parts of the value that need freeing. */
146 mpz_clear (e
->value
.integer
);
150 mpfr_clear (e
->value
.real
);
154 gfc_free (e
->value
.character
.string
);
158 mpfr_clear (e
->value
.complex.r
);
159 mpfr_clear (e
->value
.complex.i
);
166 /* Free the representation, except in character constants where it
167 is the same as value.character.string and thus already freed. */
168 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
169 gfc_free (e
->representation
.string
);
174 if (e
->value
.op
.op1
!= NULL
)
175 gfc_free_expr (e
->value
.op
.op1
);
176 if (e
->value
.op
.op2
!= NULL
)
177 gfc_free_expr (e
->value
.op
.op2
);
181 gfc_free_actual_arglist (e
->value
.function
.actual
);
189 gfc_free_constructor (e
->value
.constructor
);
193 gfc_free (e
->value
.character
.string
);
200 gfc_internal_error ("free_expr0(): Bad expr type");
203 /* Free a shape array. */
204 if (e
->shape
!= NULL
)
206 for (n
= 0; n
< e
->rank
; n
++)
207 mpz_clear (e
->shape
[n
]);
212 gfc_free_ref_list (e
->ref
);
214 memset (e
, '\0', sizeof (gfc_expr
));
218 /* Free an expression node and everything beneath it. */
221 gfc_free_expr (gfc_expr
*e
)
225 if (e
->con_by_offset
)
226 splay_tree_delete (e
->con_by_offset
);
232 /* Graft the *src expression onto the *dest subexpression. */
235 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
243 /* Try to extract an integer constant from the passed expression node.
244 Returns an error message or NULL if the result is set. It is
245 tempting to generate an error and return SUCCESS or FAILURE, but
246 failure is OK for some callers. */
249 gfc_extract_int (gfc_expr
*expr
, int *result
)
251 if (expr
->expr_type
!= EXPR_CONSTANT
)
252 return _("Constant expression required at %C");
254 if (expr
->ts
.type
!= BT_INTEGER
)
255 return _("Integer expression required at %C");
257 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
258 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
260 return _("Integer value too large in expression at %C");
263 *result
= (int) mpz_get_si (expr
->value
.integer
);
269 /* Recursively copy a list of reference structures. */
272 copy_ref (gfc_ref
*src
)
280 dest
= gfc_get_ref ();
281 dest
->type
= src
->type
;
286 ar
= gfc_copy_array_ref (&src
->u
.ar
);
292 dest
->u
.c
= src
->u
.c
;
296 dest
->u
.ss
= src
->u
.ss
;
297 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
298 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
302 dest
->next
= copy_ref (src
->next
);
308 /* Detect whether an expression has any vector index array references. */
311 gfc_has_vector_index (gfc_expr
*e
)
315 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
316 if (ref
->type
== REF_ARRAY
)
317 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
318 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
324 /* Copy a shape array. */
327 gfc_copy_shape (mpz_t
*shape
, int rank
)
335 new_shape
= gfc_get_shape (rank
);
337 for (n
= 0; n
< rank
; n
++)
338 mpz_init_set (new_shape
[n
], shape
[n
]);
344 /* Copy a shape array excluding dimension N, where N is an integer
345 constant expression. Dimensions are numbered in fortran style --
348 So, if the original shape array contains R elements
349 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
350 the result contains R-1 elements:
351 { s1 ... sN-1 sN+1 ... sR-1}
353 If anything goes wrong -- N is not a constant, its value is out
354 of range -- or anything else, just returns NULL. */
357 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
359 mpz_t
*new_shape
, *s
;
365 || dim
->expr_type
!= EXPR_CONSTANT
366 || dim
->ts
.type
!= BT_INTEGER
)
369 n
= mpz_get_si (dim
->value
.integer
);
370 n
--; /* Convert to zero based index. */
371 if (n
< 0 || n
>= rank
)
374 s
= new_shape
= gfc_get_shape (rank
- 1);
376 for (i
= 0; i
< rank
; i
++)
380 mpz_init_set (*s
, shape
[i
]);
388 /* Given an expression pointer, return a copy of the expression. This
389 subroutine is recursive. */
392 gfc_copy_expr (gfc_expr
*p
)
403 switch (q
->expr_type
)
406 s
= gfc_getmem (p
->value
.character
.length
+ 1);
407 q
->value
.character
.string
= s
;
409 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
413 /* Copy target representation, if it exists. */
414 if (p
->representation
.string
)
416 s
= gfc_getmem (p
->representation
.length
+ 1);
417 q
->representation
.string
= s
;
419 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
422 /* Copy the values of any pointer components of p->value. */
426 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
430 gfc_set_model_kind (q
->ts
.kind
);
431 mpfr_init (q
->value
.real
);
432 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
436 gfc_set_model_kind (q
->ts
.kind
);
437 mpfr_init (q
->value
.complex.r
);
438 mpfr_init (q
->value
.complex.i
);
439 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
440 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
444 if (p
->representation
.string
)
445 q
->value
.character
.string
= q
->representation
.string
;
448 s
= gfc_getmem (p
->value
.character
.length
+ 1);
449 q
->value
.character
.string
= s
;
451 /* This is the case for the C_NULL_CHAR named constant. */
452 if (p
->value
.character
.length
== 0
453 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
456 /* Need to set the length to 1 to make sure the NUL
457 terminator is copied. */
458 q
->value
.character
.length
= 1;
461 memcpy (s
, p
->value
.character
.string
,
462 p
->value
.character
.length
+ 1);
469 break; /* Already done. */
473 /* Should never be reached. */
475 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
482 switch (q
->value
.op
.operator)
485 case INTRINSIC_PARENTHESES
:
486 case INTRINSIC_UPLUS
:
487 case INTRINSIC_UMINUS
:
488 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
491 default: /* Binary operators. */
492 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
493 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
500 q
->value
.function
.actual
=
501 gfc_copy_actual_arglist (p
->value
.function
.actual
);
506 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
514 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
516 q
->ref
= copy_ref (p
->ref
);
522 /* Return the maximum kind of two expressions. In general, higher
523 kind numbers mean more precision for numeric types. */
526 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
528 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
532 /* Returns nonzero if the type is numeric, zero otherwise. */
535 numeric_type (bt type
)
537 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
541 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
544 gfc_numeric_ts (gfc_typespec
*ts
)
546 return numeric_type (ts
->type
);
550 /* Returns an expression node that is an integer constant. */
559 p
->expr_type
= EXPR_CONSTANT
;
560 p
->ts
.type
= BT_INTEGER
;
561 p
->ts
.kind
= gfc_default_integer_kind
;
563 p
->where
= gfc_current_locus
;
564 mpz_init_set_si (p
->value
.integer
, i
);
570 /* Returns an expression node that is a logical constant. */
573 gfc_logical_expr (int i
, locus
*where
)
579 p
->expr_type
= EXPR_CONSTANT
;
580 p
->ts
.type
= BT_LOGICAL
;
581 p
->ts
.kind
= gfc_default_logical_kind
;
584 where
= &gfc_current_locus
;
586 p
->value
.logical
= i
;
592 /* Return an expression node with an optional argument list attached.
593 A variable number of gfc_expr pointers are strung together in an
594 argument list with a NULL pointer terminating the list. */
597 gfc_build_conversion (gfc_expr
*e
)
602 p
->expr_type
= EXPR_FUNCTION
;
604 p
->value
.function
.actual
= NULL
;
606 p
->value
.function
.actual
= gfc_get_actual_arglist ();
607 p
->value
.function
.actual
->expr
= e
;
613 /* Given an expression node with some sort of numeric binary
614 expression, insert type conversions required to make the operands
617 The exception is that the operands of an exponential don't have to
618 have the same type. If possible, the base is promoted to the type
619 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
620 1.0**2 stays as it is. */
623 gfc_type_convert_binary (gfc_expr
*e
)
627 op1
= e
->value
.op
.op1
;
628 op2
= e
->value
.op
.op2
;
630 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
632 gfc_clear_ts (&e
->ts
);
636 /* Kind conversions of same type. */
637 if (op1
->ts
.type
== op2
->ts
.type
)
639 if (op1
->ts
.kind
== op2
->ts
.kind
)
641 /* No type conversions. */
646 if (op1
->ts
.kind
> op2
->ts
.kind
)
647 gfc_convert_type (op2
, &op1
->ts
, 2);
649 gfc_convert_type (op1
, &op2
->ts
, 2);
655 /* Integer combined with real or complex. */
656 if (op2
->ts
.type
== BT_INTEGER
)
660 /* Special case for ** operator. */
661 if (e
->value
.op
.operator == INTRINSIC_POWER
)
664 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
668 if (op1
->ts
.type
== BT_INTEGER
)
671 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
675 /* Real combined with complex. */
676 e
->ts
.type
= BT_COMPLEX
;
677 if (op1
->ts
.kind
> op2
->ts
.kind
)
678 e
->ts
.kind
= op1
->ts
.kind
;
680 e
->ts
.kind
= op2
->ts
.kind
;
681 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
682 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
683 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
684 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
692 check_specification_function (gfc_expr
*e
)
699 sym
= e
->symtree
->n
.sym
;
701 /* F95, 7.1.6.2; F2003, 7.1.7 */
703 && sym
->attr
.function
705 && !sym
->attr
.intrinsic
706 && !sym
->attr
.recursive
707 && sym
->attr
.proc
!= PROC_INTERNAL
708 && sym
->attr
.proc
!= PROC_ST_FUNCTION
709 && sym
->attr
.proc
!= PROC_UNKNOWN
710 && sym
->formal
== NULL
)
716 /* Function to determine if an expression is constant or not. This
717 function expects that the expression has already been simplified. */
720 gfc_is_constant_expr (gfc_expr
*e
)
723 gfc_actual_arglist
*arg
;
729 switch (e
->expr_type
)
732 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
733 && (e
->value
.op
.op2
== NULL
734 || gfc_is_constant_expr (e
->value
.op
.op2
)));
742 /* Specification functions are constant. */
743 if (check_specification_function (e
) == MATCH_YES
)
749 /* Call to intrinsic with at least one argument. */
751 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
753 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
755 if (!gfc_is_constant_expr (arg
->expr
))
769 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
770 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
775 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
776 if (!gfc_is_constant_expr (c
->expr
))
784 rv
= gfc_constant_ac (e
);
788 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
795 /* Try to collapse intrinsic expressions. */
798 simplify_intrinsic_op (gfc_expr
*p
, int type
)
801 gfc_expr
*op1
, *op2
, *result
;
803 if (p
->value
.op
.operator == INTRINSIC_USER
)
806 op1
= p
->value
.op
.op1
;
807 op2
= p
->value
.op
.op2
;
808 op
= p
->value
.op
.operator;
810 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
812 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
815 if (!gfc_is_constant_expr (op1
)
816 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
820 p
->value
.op
.op1
= NULL
;
821 p
->value
.op
.op2
= NULL
;
825 case INTRINSIC_PARENTHESES
:
826 result
= gfc_parentheses (op1
);
829 case INTRINSIC_UPLUS
:
830 result
= gfc_uplus (op1
);
833 case INTRINSIC_UMINUS
:
834 result
= gfc_uminus (op1
);
838 result
= gfc_add (op1
, op2
);
841 case INTRINSIC_MINUS
:
842 result
= gfc_subtract (op1
, op2
);
845 case INTRINSIC_TIMES
:
846 result
= gfc_multiply (op1
, op2
);
849 case INTRINSIC_DIVIDE
:
850 result
= gfc_divide (op1
, op2
);
853 case INTRINSIC_POWER
:
854 result
= gfc_power (op1
, op2
);
857 case INTRINSIC_CONCAT
:
858 result
= gfc_concat (op1
, op2
);
862 case INTRINSIC_EQ_OS
:
863 result
= gfc_eq (op1
, op2
, op
);
867 case INTRINSIC_NE_OS
:
868 result
= gfc_ne (op1
, op2
, op
);
872 case INTRINSIC_GT_OS
:
873 result
= gfc_gt (op1
, op2
, op
);
877 case INTRINSIC_GE_OS
:
878 result
= gfc_ge (op1
, op2
, op
);
882 case INTRINSIC_LT_OS
:
883 result
= gfc_lt (op1
, op2
, op
);
887 case INTRINSIC_LE_OS
:
888 result
= gfc_le (op1
, op2
, op
);
892 result
= gfc_not (op1
);
896 result
= gfc_and (op1
, op2
);
900 result
= gfc_or (op1
, op2
);
904 result
= gfc_eqv (op1
, op2
);
908 result
= gfc_neqv (op1
, op2
);
912 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
922 result
->rank
= p
->rank
;
923 result
->where
= p
->where
;
924 gfc_replace_expr (p
, result
);
930 /* Subroutine to simplify constructor expressions. Mutually recursive
931 with gfc_simplify_expr(). */
934 simplify_constructor (gfc_constructor
*c
, int type
)
936 for (; c
; c
= c
->next
)
939 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
940 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
941 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
944 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
952 /* Pull a single array element out of an array constructor. */
955 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
956 gfc_constructor
**rval
)
958 unsigned long nelemen
;
970 mpz_init_set_ui (offset
, 0);
973 mpz_init_set_ui (span
, 1);
974 for (i
= 0; i
< ar
->dimen
; i
++)
976 e
= gfc_copy_expr (ar
->start
[i
]);
977 if (e
->expr_type
!= EXPR_CONSTANT
)
983 /* Check the bounds. */
985 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
986 || mpz_cmp (e
->value
.integer
,
987 ar
->as
->lower
[i
]->value
.integer
) < 0))
989 gfc_error ("index in dimension %d is out of bounds "
990 "at %L", i
+ 1, &ar
->c_where
[i
]);
996 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
997 mpz_mul (delta
, delta
, span
);
998 mpz_add (offset
, offset
, delta
);
1000 mpz_set_ui (tmp
, 1);
1001 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1002 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1003 mpz_mul (span
, span
, tmp
);
1008 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1031 /* Find a component of a structure constructor. */
1033 static gfc_constructor
*
1034 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1036 gfc_component
*comp
;
1037 gfc_component
*pick
;
1039 comp
= ref
->u
.c
.sym
->components
;
1040 pick
= ref
->u
.c
.component
;
1041 while (comp
!= pick
)
1051 /* Replace an expression with the contents of a constructor, removing
1052 the subobject reference in the process. */
1055 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1061 e
->ref
= p
->ref
->next
;
1062 p
->ref
->next
= NULL
;
1063 gfc_replace_expr (p
, e
);
1067 /* Pull an array section out of an array constructor. */
1070 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1076 long unsigned one
= 1;
1078 mpz_t start
[GFC_MAX_DIMENSIONS
];
1079 mpz_t end
[GFC_MAX_DIMENSIONS
];
1080 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1081 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1082 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1088 gfc_constructor
*cons
;
1089 gfc_constructor
*base
;
1095 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1100 base
= expr
->value
.constructor
;
1101 expr
->value
.constructor
= NULL
;
1103 rank
= ref
->u
.ar
.as
->rank
;
1105 if (expr
->shape
== NULL
)
1106 expr
->shape
= gfc_get_shape (rank
);
1108 mpz_init_set_ui (delta_mpz
, one
);
1109 mpz_init_set_ui (nelts
, one
);
1112 /* Do the initialization now, so that we can cleanup without
1113 keeping track of where we were. */
1114 for (d
= 0; d
< rank
; d
++)
1116 mpz_init (delta
[d
]);
1117 mpz_init (start
[d
]);
1120 mpz_init (stride
[d
]);
1124 /* Build the counters to clock through the array reference. */
1126 for (d
= 0; d
< rank
; d
++)
1128 /* Make this stretch of code easier on the eye! */
1129 begin
= ref
->u
.ar
.start
[d
];
1130 finish
= ref
->u
.ar
.end
[d
];
1131 step
= ref
->u
.ar
.stride
[d
];
1132 lower
= ref
->u
.ar
.as
->lower
[d
];
1133 upper
= ref
->u
.ar
.as
->upper
[d
];
1135 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1139 if (begin
->expr_type
!= EXPR_ARRAY
)
1145 gcc_assert (begin
->rank
== 1);
1146 gcc_assert (begin
->shape
);
1148 vecsub
[d
] = begin
->value
.constructor
;
1149 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1150 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1151 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1154 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1156 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1157 || mpz_cmp (c
->expr
->value
.integer
,
1158 lower
->value
.integer
) < 0)
1160 gfc_error ("index in dimension %d is out of bounds "
1161 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1169 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1170 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1171 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1177 /* Obtain the stride. */
1179 mpz_set (stride
[d
], step
->value
.integer
);
1181 mpz_set_ui (stride
[d
], one
);
1183 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1184 mpz_set_ui (stride
[d
], one
);
1186 /* Obtain the start value for the index. */
1188 mpz_set (start
[d
], begin
->value
.integer
);
1190 mpz_set (start
[d
], lower
->value
.integer
);
1192 mpz_set (ctr
[d
], start
[d
]);
1194 /* Obtain the end value for the index. */
1196 mpz_set (end
[d
], finish
->value
.integer
);
1198 mpz_set (end
[d
], upper
->value
.integer
);
1200 /* Separate 'if' because elements sometimes arrive with
1202 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1203 mpz_set (end
[d
], begin
->value
.integer
);
1205 /* Check the bounds. */
1206 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1207 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1208 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1209 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1211 gfc_error ("index in dimension %d is out of bounds "
1212 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1217 /* Calculate the number of elements and the shape. */
1218 mpz_set (tmp_mpz
, stride
[d
]);
1219 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1220 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1221 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1222 mpz_mul (nelts
, nelts
, tmp_mpz
);
1224 /* An element reference reduces the rank of the expression; don't
1225 add anything to the shape array. */
1226 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1227 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1230 /* Calculate the 'stride' (=delta) for conversion of the
1231 counter values into the index along the constructor. */
1232 mpz_set (delta
[d
], delta_mpz
);
1233 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1234 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1235 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1242 /* Now clock through the array reference, calculating the index in
1243 the source constructor and transferring the elements to the new
1245 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1247 if (ref
->u
.ar
.offset
)
1248 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1250 mpz_init_set_ui (ptr
, 0);
1253 for (d
= 0; d
< rank
; d
++)
1255 mpz_set (tmp_mpz
, ctr
[d
]);
1256 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1257 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1258 mpz_add (ptr
, ptr
, tmp_mpz
);
1260 if (!incr_ctr
) continue;
1262 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1264 gcc_assert(vecsub
[d
]);
1266 if (!vecsub
[d
]->next
)
1267 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1270 vecsub
[d
] = vecsub
[d
]->next
;
1273 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1277 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1279 if (mpz_cmp_ui (stride
[d
], 0) > 0
1280 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1281 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1282 mpz_set (ctr
[d
], start
[d
]);
1288 /* There must be a better way of dealing with negative strides
1289 than resetting the index and the constructor pointer! */
1290 if (mpz_cmp (ptr
, index
) < 0)
1292 mpz_set_ui (index
, 0);
1296 while (mpz_cmp (ptr
, index
) > 0)
1298 mpz_add_ui (index
, index
, one
);
1302 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1310 mpz_clear (delta_mpz
);
1311 mpz_clear (tmp_mpz
);
1313 for (d
= 0; d
< rank
; d
++)
1315 mpz_clear (delta
[d
]);
1316 mpz_clear (start
[d
]);
1319 mpz_clear (stride
[d
]);
1321 gfc_free_constructor (base
);
1325 /* Pull a substring out of an expression. */
1328 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1335 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1336 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1339 *newp
= gfc_copy_expr (p
);
1340 gfc_free ((*newp
)->value
.character
.string
);
1342 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1343 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1344 length
= end
- start
+ 1;
1346 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1347 (*newp
)->value
.character
.length
= length
;
1348 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1355 /* Simplify a subobject reference of a constructor. This occurs when
1356 parameter variable values are substituted. */
1359 simplify_const_ref (gfc_expr
*p
)
1361 gfc_constructor
*cons
;
1366 switch (p
->ref
->type
)
1369 switch (p
->ref
->u
.ar
.type
)
1372 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1379 remove_subobject_ref (p
, cons
);
1383 if (find_array_section (p
, p
->ref
) == FAILURE
)
1385 p
->ref
->u
.ar
.type
= AR_FULL
;
1390 if (p
->ref
->next
!= NULL
1391 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1393 cons
= p
->value
.constructor
;
1394 for (; cons
; cons
= cons
->next
)
1396 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1397 simplify_const_ref (cons
->expr
);
1400 gfc_free_ref_list (p
->ref
);
1411 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1412 remove_subobject_ref (p
, cons
);
1416 if (find_substring_ref (p
, &newp
) == FAILURE
)
1419 gfc_replace_expr (p
, newp
);
1420 gfc_free_ref_list (p
->ref
);
1430 /* Simplify a chain of references. */
1433 simplify_ref_chain (gfc_ref
*ref
, int type
)
1437 for (; ref
; ref
= ref
->next
)
1442 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1444 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1446 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1448 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1454 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1456 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1468 /* Try to substitute the value of a parameter variable. */
1471 simplify_parameter_variable (gfc_expr
*p
, int type
)
1476 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1482 /* Do not copy subobject refs for constant. */
1483 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1484 e
->ref
= copy_ref (p
->ref
);
1485 t
= gfc_simplify_expr (e
, type
);
1487 /* Only use the simplification if it eliminated all subobject references. */
1488 if (t
== SUCCESS
&& !e
->ref
)
1489 gfc_replace_expr (p
, e
);
1496 /* Given an expression, simplify it by collapsing constant
1497 expressions. Most simplification takes place when the expression
1498 tree is being constructed. If an intrinsic function is simplified
1499 at some point, we get called again to collapse the result against
1502 We work by recursively simplifying expression nodes, simplifying
1503 intrinsic functions where possible, which can lead to further
1504 constant collapsing. If an operator has constant operand(s), we
1505 rip the expression apart, and rebuild it, hoping that it becomes
1508 The expression type is defined for:
1509 0 Basic expression parsing
1510 1 Simplifying array constructors -- will substitute
1512 Returns FAILURE on error, SUCCESS otherwise.
1513 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1516 gfc_simplify_expr (gfc_expr
*p
, int type
)
1518 gfc_actual_arglist
*ap
;
1523 switch (p
->expr_type
)
1530 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1531 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1534 if (p
->value
.function
.isym
!= NULL
1535 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1540 case EXPR_SUBSTRING
:
1541 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1544 if (gfc_is_constant_expr (p
))
1549 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1551 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1552 start
--; /* Convert from one-based to zero-based. */
1557 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1558 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1560 end
= p
->value
.character
.length
;
1562 s
= gfc_getmem (end
- start
+ 2);
1563 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1564 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1565 gfc_free (p
->value
.character
.string
);
1566 p
->value
.character
.string
= s
;
1567 p
->value
.character
.length
= end
- start
;
1568 p
->ts
.cl
= gfc_get_charlen ();
1569 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1570 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1571 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1572 gfc_free_ref_list (p
->ref
);
1574 p
->expr_type
= EXPR_CONSTANT
;
1579 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1584 /* Only substitute array parameter variables if we are in an
1585 initialization expression, or we want a subsection. */
1586 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1587 && (gfc_init_expr
|| p
->ref
1588 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1590 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1597 gfc_simplify_iterator_var (p
);
1600 /* Simplify subcomponent references. */
1601 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1606 case EXPR_STRUCTURE
:
1608 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1611 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1614 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1615 && p
->ref
->u
.ar
.type
== AR_FULL
)
1616 gfc_expand_constructor (p
);
1618 if (simplify_const_ref (p
) == FAILURE
)
1628 /* Returns the type of an expression with the exception that iterator
1629 variables are automatically integers no matter what else they may
1635 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1642 /* Check an intrinsic arithmetic operation to see if it is consistent
1643 with some type of expression. */
1645 static try check_init_expr (gfc_expr
*);
1648 /* Scalarize an expression for an elemental intrinsic call. */
1651 scalarize_intrinsic_call (gfc_expr
*e
)
1653 gfc_actual_arglist
*a
, *b
;
1654 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1655 gfc_expr
*expr
, *old
;
1658 old
= gfc_copy_expr (e
);
1660 /* Assume that the old expression carries the type information and
1661 that the first arg carries all the shape information. */
1662 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1663 gfc_free_constructor (expr
->value
.constructor
);
1664 expr
->value
.constructor
= NULL
;
1667 expr
->expr_type
= EXPR_ARRAY
;
1669 /* Copy the array argument constructors into an array, with nulls
1672 a
= old
->value
.function
.actual
;
1673 for (; a
; a
= a
->next
)
1675 /* Check that this is OK for an initialization expression. */
1676 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1680 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1682 rank
[n
] = a
->expr
->rank
;
1683 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1684 args
[n
] = gfc_copy_constructor (ctor
);
1686 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1689 rank
[n
] = a
->expr
->rank
;
1692 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1699 for (i
= 1; i
< n
; i
++)
1700 if (rank
[i
] && rank
[i
] != rank
[0])
1703 /* Using the first argument as the master, step through the array
1704 calling the function for each element and advancing the array
1705 constructors together. */
1708 for (; ctor
; ctor
= ctor
->next
)
1710 if (expr
->value
.constructor
== NULL
)
1711 expr
->value
.constructor
1712 = new_ctor
= gfc_get_constructor ();
1715 new_ctor
->next
= gfc_get_constructor ();
1716 new_ctor
= new_ctor
->next
;
1718 new_ctor
->expr
= gfc_copy_expr (old
);
1719 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1721 b
= old
->value
.function
.actual
;
1722 for (i
= 0; i
< n
; i
++)
1725 new_ctor
->expr
->value
.function
.actual
1726 = a
= gfc_get_actual_arglist ();
1729 a
->next
= gfc_get_actual_arglist ();
1733 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1735 a
->expr
= gfc_copy_expr (b
->expr
);
1740 /* Simplify the function calls. */
1741 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1744 for (i
= 0; i
< n
; i
++)
1746 args
[i
] = args
[i
]->next
;
1748 for (i
= 1; i
< n
; i
++)
1749 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1750 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1756 gfc_free_expr (old
);
1760 gfc_error_now ("elemental function arguments at %C are not compliant");
1763 gfc_free_expr (expr
);
1764 gfc_free_expr (old
);
1770 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1772 gfc_expr
*op1
= e
->value
.op
.op1
;
1773 gfc_expr
*op2
= e
->value
.op
.op2
;
1775 if ((*check_function
) (op1
) == FAILURE
)
1778 switch (e
->value
.op
.operator)
1780 case INTRINSIC_UPLUS
:
1781 case INTRINSIC_UMINUS
:
1782 if (!numeric_type (et0 (op1
)))
1787 case INTRINSIC_EQ_OS
:
1789 case INTRINSIC_NE_OS
:
1791 case INTRINSIC_GT_OS
:
1793 case INTRINSIC_GE_OS
:
1795 case INTRINSIC_LT_OS
:
1797 case INTRINSIC_LE_OS
:
1798 if ((*check_function
) (op2
) == FAILURE
)
1801 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1802 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1804 gfc_error ("Numeric or CHARACTER operands are required in "
1805 "expression at %L", &e
->where
);
1810 case INTRINSIC_PLUS
:
1811 case INTRINSIC_MINUS
:
1812 case INTRINSIC_TIMES
:
1813 case INTRINSIC_DIVIDE
:
1814 case INTRINSIC_POWER
:
1815 if ((*check_function
) (op2
) == FAILURE
)
1818 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1821 if (e
->value
.op
.operator == INTRINSIC_POWER
1822 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1824 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1825 "exponent in an initialization "
1826 "expression at %L", &op2
->where
)
1833 case INTRINSIC_CONCAT
:
1834 if ((*check_function
) (op2
) == FAILURE
)
1837 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1839 gfc_error ("Concatenation operator in expression at %L "
1840 "must have two CHARACTER operands", &op1
->where
);
1844 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1846 gfc_error ("Concat operator at %L must concatenate strings of the "
1847 "same kind", &e
->where
);
1854 if (et0 (op1
) != BT_LOGICAL
)
1856 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1857 "operand", &op1
->where
);
1866 case INTRINSIC_NEQV
:
1867 if ((*check_function
) (op2
) == FAILURE
)
1870 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1872 gfc_error ("LOGICAL operands are required in expression at %L",
1879 case INTRINSIC_PARENTHESES
:
1883 gfc_error ("Only intrinsic operators can be used in expression at %L",
1891 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1898 check_init_expr_arguments (gfc_expr
*e
)
1900 gfc_actual_arglist
*ap
;
1902 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1903 if (check_init_expr (ap
->expr
) == FAILURE
)
1909 /* F95, 7.1.6.1, Initialization expressions, (7)
1910 F2003, 7.1.7 Initialization expression, (8) */
1913 check_inquiry (gfc_expr
*e
, int not_restricted
)
1916 const char *const *functions
;
1918 static const char *const inquiry_func_f95
[] = {
1919 "lbound", "shape", "size", "ubound",
1920 "bit_size", "len", "kind",
1921 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1922 "precision", "radix", "range", "tiny",
1926 static const char *const inquiry_func_f2003
[] = {
1927 "lbound", "shape", "size", "ubound",
1928 "bit_size", "len", "kind",
1929 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1930 "precision", "radix", "range", "tiny",
1935 gfc_actual_arglist
*ap
;
1937 if (!e
->value
.function
.isym
1938 || !e
->value
.function
.isym
->inquiry
)
1941 /* An undeclared parameter will get us here (PR25018). */
1942 if (e
->symtree
== NULL
)
1945 name
= e
->symtree
->n
.sym
->name
;
1947 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1948 ? inquiry_func_f2003
: inquiry_func_f95
;
1950 for (i
= 0; functions
[i
]; i
++)
1951 if (strcmp (functions
[i
], name
) == 0)
1954 if (functions
[i
] == NULL
)
1956 gfc_error ("Inquiry function '%s' at %L is not permitted "
1957 "in an initialization expression", name
, &e
->where
);
1961 /* At this point we have an inquiry function with a variable argument. The
1962 type of the variable might be undefined, but we need it now, because the
1963 arguments of these functions are not allowed to be undefined. */
1965 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1970 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
1972 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1973 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
1977 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
1980 /* Assumed character length will not reduce to a constant expression
1981 with LEN, as required by the standard. */
1982 if (i
== 5 && not_restricted
1983 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1984 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1986 gfc_error ("assumed character length variable '%s' in constant "
1987 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
1990 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
1998 /* F95, 7.1.6.1, Initialization expressions, (5)
1999 F2003, 7.1.7 Initialization expression, (5) */
2002 check_transformational (gfc_expr
*e
)
2004 static const char * const trans_func_f95
[] = {
2005 "repeat", "reshape", "selected_int_kind",
2006 "selected_real_kind", "transfer", "trim", NULL
2012 if (!e
->value
.function
.isym
2013 || !e
->value
.function
.isym
->transformational
)
2016 name
= e
->symtree
->n
.sym
->name
;
2018 /* NULL() is dealt with below. */
2019 if (strcmp ("null", name
) == 0)
2022 for (i
= 0; trans_func_f95
[i
]; i
++)
2023 if (strcmp (trans_func_f95
[i
], name
) == 0)
2026 /* FIXME, F2003: implement translation of initialization
2027 expressions before enabling this check. For F95, error
2028 out if the transformational function is not in the list. */
2030 if (trans_func_f95
[i
] == NULL
2031 && gfc_notify_std (GFC_STD_F2003
,
2032 "transformational intrinsic '%s' at %L is not permitted "
2033 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2036 if (trans_func_f95
[i
] == NULL
)
2038 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2039 "in an initialization expression", name
, &e
->where
);
2044 return check_init_expr_arguments (e
);
2048 /* F95, 7.1.6.1, Initialization expressions, (6)
2049 F2003, 7.1.7 Initialization expression, (6) */
2052 check_null (gfc_expr
*e
)
2054 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2057 return check_init_expr_arguments (e
);
2062 check_elemental (gfc_expr
*e
)
2064 if (!e
->value
.function
.isym
2065 || !e
->value
.function
.isym
->elemental
)
2068 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2069 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2070 "nonstandard initialization expression at %L",
2071 &e
->where
) == FAILURE
)
2074 return check_init_expr_arguments (e
);
2079 check_conversion (gfc_expr
*e
)
2081 if (!e
->value
.function
.isym
2082 || !e
->value
.function
.isym
->conversion
)
2085 return check_init_expr_arguments (e
);
2089 /* Verify that an expression is an initialization expression. A side
2090 effect is that the expression tree is reduced to a single constant
2091 node if all goes well. This would normally happen when the
2092 expression is constructed but function references are assumed to be
2093 intrinsics in the context of initialization expressions. If
2094 FAILURE is returned an error message has been generated. */
2097 check_init_expr (gfc_expr
*e
)
2101 gfc_intrinsic_sym
*isym
;
2106 switch (e
->expr_type
)
2109 t
= check_intrinsic_op (e
, check_init_expr
);
2111 t
= gfc_simplify_expr (e
, 0);
2118 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2120 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2122 gfc_error ("Function '%s' in initialization expression at %L "
2123 "must be an intrinsic or a specification function",
2124 e
->symtree
->n
.sym
->name
, &e
->where
);
2128 if ((m
= check_conversion (e
)) == MATCH_NO
2129 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2130 && (m
= check_null (e
)) == MATCH_NO
2131 && (m
= check_transformational (e
)) == MATCH_NO
2132 && (m
= check_elemental (e
)) == MATCH_NO
)
2134 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2135 "in an initialization expression",
2136 e
->symtree
->n
.sym
->name
, &e
->where
);
2140 /* Try to scalarize an elemental intrinsic function that has an
2142 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2143 if (isym
&& isym
->elemental
2144 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2146 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2152 t
= gfc_simplify_expr (e
, 0);
2159 if (gfc_check_iter_variable (e
) == SUCCESS
)
2162 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2164 t
= simplify_parameter_variable (e
, 0);
2168 if (gfc_in_match_data ())
2173 if (e
->symtree
->n
.sym
->as
)
2175 switch (e
->symtree
->n
.sym
->as
->type
)
2177 case AS_ASSUMED_SIZE
:
2178 gfc_error ("assumed size array '%s' at %L is not permitted "
2179 "in an initialization expression",
2180 e
->symtree
->n
.sym
->name
, &e
->where
);
2183 case AS_ASSUMED_SHAPE
:
2184 gfc_error ("assumed shape array '%s' at %L is not permitted "
2185 "in an initialization expression",
2186 e
->symtree
->n
.sym
->name
, &e
->where
);
2190 gfc_error ("deferred array '%s' at %L is not permitted "
2191 "in an initialization expression",
2192 e
->symtree
->n
.sym
->name
, &e
->where
);
2200 gfc_error ("Parameter '%s' at %L has not been declared or is "
2201 "a variable, which does not reduce to a constant "
2202 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2211 case EXPR_SUBSTRING
:
2212 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2216 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2218 t
= gfc_simplify_expr (e
, 0);
2222 case EXPR_STRUCTURE
:
2223 t
= gfc_check_constructor (e
, check_init_expr
);
2227 t
= gfc_check_constructor (e
, check_init_expr
);
2231 t
= gfc_expand_constructor (e
);
2235 t
= gfc_check_constructor_type (e
);
2239 gfc_internal_error ("check_init_expr(): Unknown expression type");
2246 /* Match an initialization expression. We work by first matching an
2247 expression, then reducing it to a constant. */
2250 gfc_match_init_expr (gfc_expr
**result
)
2256 m
= gfc_match_expr (&expr
);
2261 t
= gfc_resolve_expr (expr
);
2263 t
= check_init_expr (expr
);
2268 gfc_free_expr (expr
);
2272 if (expr
->expr_type
== EXPR_ARRAY
2273 && (gfc_check_constructor_type (expr
) == FAILURE
2274 || gfc_expand_constructor (expr
) == FAILURE
))
2276 gfc_free_expr (expr
);
2280 /* Not all inquiry functions are simplified to constant expressions
2281 so it is necessary to call check_inquiry again. */
2282 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2283 && !gfc_in_match_data ())
2285 gfc_error ("Initialization expression didn't reduce %C");
2295 static try check_restricted (gfc_expr
*);
2297 /* Given an actual argument list, test to see that each argument is a
2298 restricted expression and optionally if the expression type is
2299 integer or character. */
2302 restricted_args (gfc_actual_arglist
*a
)
2304 for (; a
; a
= a
->next
)
2306 if (check_restricted (a
->expr
) == FAILURE
)
2314 /************* Restricted/specification expressions *************/
2317 /* Make sure a non-intrinsic function is a specification function. */
2320 external_spec_function (gfc_expr
*e
)
2324 f
= e
->value
.function
.esym
;
2326 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2328 gfc_error ("Specification function '%s' at %L cannot be a statement "
2329 "function", f
->name
, &e
->where
);
2333 if (f
->attr
.proc
== PROC_INTERNAL
)
2335 gfc_error ("Specification function '%s' at %L cannot be an internal "
2336 "function", f
->name
, &e
->where
);
2340 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2342 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2347 if (f
->attr
.recursive
)
2349 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2350 f
->name
, &e
->where
);
2354 return restricted_args (e
->value
.function
.actual
);
2358 /* Check to see that a function reference to an intrinsic is a
2359 restricted expression. */
2362 restricted_intrinsic (gfc_expr
*e
)
2364 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2365 if (check_inquiry (e
, 0) == MATCH_YES
)
2368 return restricted_args (e
->value
.function
.actual
);
2372 /* Verify that an expression is a restricted expression. Like its
2373 cousin check_init_expr(), an error message is generated if we
2377 check_restricted (gfc_expr
*e
)
2385 switch (e
->expr_type
)
2388 t
= check_intrinsic_op (e
, check_restricted
);
2390 t
= gfc_simplify_expr (e
, 0);
2395 t
= e
->value
.function
.esym
? external_spec_function (e
)
2396 : restricted_intrinsic (e
);
2400 sym
= e
->symtree
->n
.sym
;
2403 if (sym
->attr
.optional
)
2405 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2406 sym
->name
, &e
->where
);
2410 if (sym
->attr
.intent
== INTENT_OUT
)
2412 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2413 sym
->name
, &e
->where
);
2417 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2418 processed in resolve.c(resolve_formal_arglist). This is done so
2419 that host associated dummy array indices are accepted (PR23446).
2420 This mechanism also does the same for the specification expressions
2421 of array-valued functions. */
2422 if (sym
->attr
.in_common
2423 || sym
->attr
.use_assoc
2425 || sym
->ns
!= gfc_current_ns
2426 || (sym
->ns
->proc_name
!= NULL
2427 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2428 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2434 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2435 sym
->name
, &e
->where
);
2444 case EXPR_SUBSTRING
:
2445 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2449 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2451 t
= gfc_simplify_expr (e
, 0);
2455 case EXPR_STRUCTURE
:
2456 t
= gfc_check_constructor (e
, check_restricted
);
2460 t
= gfc_check_constructor (e
, check_restricted
);
2464 gfc_internal_error ("check_restricted(): Unknown expression type");
2471 /* Check to see that an expression is a specification expression. If
2472 we return FAILURE, an error has been generated. */
2475 gfc_specification_expr (gfc_expr
*e
)
2481 if (e
->ts
.type
!= BT_INTEGER
)
2483 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2489 gfc_error ("Expression at %L must be scalar", &e
->where
);
2493 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2496 return check_restricted (e
);
2500 /************** Expression conformance checks. *************/
2502 /* Given two expressions, make sure that the arrays are conformable. */
2505 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2507 int op1_flag
, op2_flag
, d
;
2508 mpz_t op1_size
, op2_size
;
2511 if (op1
->rank
== 0 || op2
->rank
== 0)
2514 if (op1
->rank
!= op2
->rank
)
2516 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2517 op1
->rank
, op2
->rank
, &op1
->where
);
2523 for (d
= 0; d
< op1
->rank
; d
++)
2525 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2526 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2528 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2530 gfc_error ("different shape for %s at %L on dimension %d (%d and %d)",
2531 _(optype_msgid
), &op1
->where
, d
+ 1,
2532 (int) mpz_get_si (op1_size
),
2533 (int) mpz_get_si (op2_size
));
2539 mpz_clear (op1_size
);
2541 mpz_clear (op2_size
);
2551 /* Given an assignable expression and an arbitrary expression, make
2552 sure that the assignment can take place. */
2555 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2561 sym
= lvalue
->symtree
->n
.sym
;
2563 /* Check INTENT(IN), unless the object itself is the component or
2564 sub-component of a pointer. */
2565 has_pointer
= sym
->attr
.pointer
;
2567 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2568 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2574 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2576 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2577 sym
->name
, &lvalue
->where
);
2581 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2582 variable local to a function subprogram. Its existence begins when
2583 execution of the function is initiated and ends when execution of the
2584 function is terminated...
2585 Therefore, the left hand side is no longer a variable, when it is: */
2586 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2587 && !sym
->attr
.external
)
2592 /* (i) Use associated; */
2593 if (sym
->attr
.use_assoc
)
2596 /* (ii) The assignment is in the main program; or */
2597 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2600 /* (iii) A module or internal procedure... */
2601 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2602 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2603 && gfc_current_ns
->parent
2604 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2605 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2606 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2608 /* ... that is not a function... */
2609 if (!gfc_current_ns
->proc_name
->attr
.function
)
2612 /* ... or is not an entry and has a different name. */
2613 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2619 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2624 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2626 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2627 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2631 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2633 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2638 if (rvalue
->expr_type
== EXPR_NULL
)
2640 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2641 && lvalue
->symtree
->n
.sym
->attr
.data
)
2645 gfc_error ("NULL appears on right-hand side in assignment at %L",
2651 if (sym
->attr
.cray_pointee
2652 && lvalue
->ref
!= NULL
2653 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2654 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2656 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2657 "is illegal", &lvalue
->where
);
2661 /* This is possibly a typo: x = f() instead of x => f(). */
2662 if (gfc_option
.warn_surprising
2663 && rvalue
->expr_type
== EXPR_FUNCTION
2664 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2665 gfc_warning ("POINTER valued function appears on right-hand side of "
2666 "assignment at %L", &rvalue
->where
);
2668 /* Check size of array assignments. */
2669 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2670 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2673 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2678 /* Numeric can be converted to any other numeric. And Hollerith can be
2679 converted to any other type. */
2680 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2681 || rvalue
->ts
.type
== BT_HOLLERITH
)
2684 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2687 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2688 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2689 gfc_typename (&lvalue
->ts
));
2694 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2698 /* Check that a pointer assignment is OK. We first check lvalue, and
2699 we only check rvalue if it's not an assignment to NULL() or a
2700 NULLIFY statement. */
2703 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2705 symbol_attribute attr
;
2708 int pointer
, check_intent_in
;
2710 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2712 gfc_error ("Pointer assignment target is not a POINTER at %L",
2717 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2718 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2720 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2721 "l-value since it is a procedure",
2722 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2727 /* Check INTENT(IN), unless the object itself is the component or
2728 sub-component of a pointer. */
2729 check_intent_in
= 1;
2730 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2732 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2735 check_intent_in
= 0;
2737 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2741 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2743 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2744 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2750 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2754 is_pure
= gfc_pure (NULL
);
2756 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2757 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2759 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2763 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2764 kind, etc for lvalue and rvalue must match, and rvalue must be a
2765 pure variable if we're in a pure function. */
2766 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2769 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2771 gfc_error ("Different types in pointer assignment at %L",
2776 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2778 gfc_error ("Different kind type parameters in pointer "
2779 "assignment at %L", &lvalue
->where
);
2783 if (lvalue
->rank
!= rvalue
->rank
)
2785 gfc_error ("Different ranks in pointer assignment at %L",
2790 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2791 if (rvalue
->expr_type
== EXPR_NULL
)
2794 if (lvalue
->ts
.type
== BT_CHARACTER
2795 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2796 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2797 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2798 rvalue
->ts
.cl
->length
)) == 1)
2800 gfc_error ("Different character lengths in pointer "
2801 "assignment at %L", &lvalue
->where
);
2805 attr
= gfc_expr_attr (rvalue
);
2806 if (!attr
.target
&& !attr
.pointer
)
2808 gfc_error ("Pointer assignment target is neither TARGET "
2809 "nor POINTER at %L", &rvalue
->where
);
2813 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2815 gfc_error ("Bad target in pointer assignment in PURE "
2816 "procedure at %L", &rvalue
->where
);
2819 if (gfc_has_vector_index (rvalue
))
2821 gfc_error ("Pointer assignment with vector subscript "
2822 "on rhs at %L", &rvalue
->where
);
2826 if (attr
.protected && attr
.use_assoc
)
2828 gfc_error ("Pointer assigment target has PROTECTED "
2829 "attribute at %L", &rvalue
->where
);
2837 /* Relative of gfc_check_assign() except that the lvalue is a single
2838 symbol. Used for initialization assignments. */
2841 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2846 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2848 lvalue
.expr_type
= EXPR_VARIABLE
;
2849 lvalue
.ts
= sym
->ts
;
2851 lvalue
.rank
= sym
->as
->rank
;
2852 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2853 lvalue
.symtree
->n
.sym
= sym
;
2854 lvalue
.where
= sym
->declared_at
;
2856 if (sym
->attr
.pointer
)
2857 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2859 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2861 gfc_free (lvalue
.symtree
);
2867 /* Get an expression for a default initializer. */
2870 gfc_default_initializer (gfc_typespec
*ts
)
2872 gfc_constructor
*tail
;
2878 /* See if we have a default initializer. */
2879 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2881 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2882 init
= gfc_get_expr ();
2888 /* Build the constructor. */
2889 init
->expr_type
= EXPR_STRUCTURE
;
2891 init
->where
= ts
->derived
->declared_at
;
2893 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2896 init
->value
.constructor
= tail
= gfc_get_constructor ();
2899 tail
->next
= gfc_get_constructor ();
2904 tail
->expr
= gfc_copy_expr (c
->initializer
);
2908 tail
->expr
= gfc_get_expr ();
2909 tail
->expr
->expr_type
= EXPR_NULL
;
2910 tail
->expr
->ts
= c
->ts
;
2917 /* Given a symbol, create an expression node with that symbol as a
2918 variable. If the symbol is array valued, setup a reference of the
2922 gfc_get_variable_expr (gfc_symtree
*var
)
2926 e
= gfc_get_expr ();
2927 e
->expr_type
= EXPR_VARIABLE
;
2929 e
->ts
= var
->n
.sym
->ts
;
2931 if (var
->n
.sym
->as
!= NULL
)
2933 e
->rank
= var
->n
.sym
->as
->rank
;
2934 e
->ref
= gfc_get_ref ();
2935 e
->ref
->type
= REF_ARRAY
;
2936 e
->ref
->u
.ar
.type
= AR_FULL
;
2943 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2946 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2948 gfc_actual_arglist
*arg
;
2955 switch (expr
->expr_type
)
2958 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2959 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2963 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2964 gfc_expr_set_symbols_referenced (arg
->expr
);
2968 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2973 case EXPR_SUBSTRING
:
2976 case EXPR_STRUCTURE
:
2978 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2979 gfc_expr_set_symbols_referenced (c
->expr
);
2987 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2991 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2993 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2994 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2995 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
3003 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
3004 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);