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/>. */
27 #include "target-memory.h" /* for gfc_convert_boz */
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);
693 check_specification_function (gfc_expr
*e
)
700 sym
= e
->symtree
->n
.sym
;
702 /* F95, 7.1.6.2; F2003, 7.1.7 */
704 && sym
->attr
.function
706 && !sym
->attr
.intrinsic
707 && !sym
->attr
.recursive
708 && sym
->attr
.proc
!= PROC_INTERNAL
709 && sym
->attr
.proc
!= PROC_ST_FUNCTION
710 && sym
->attr
.proc
!= PROC_UNKNOWN
711 && sym
->formal
== NULL
)
717 /* Function to determine if an expression is constant or not. This
718 function expects that the expression has already been simplified. */
721 gfc_is_constant_expr (gfc_expr
*e
)
724 gfc_actual_arglist
*arg
;
730 switch (e
->expr_type
)
733 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
734 && (e
->value
.op
.op2
== NULL
735 || gfc_is_constant_expr (e
->value
.op
.op2
)));
743 /* Specification functions are constant. */
744 if (check_specification_function (e
) == MATCH_YES
)
750 /* Call to intrinsic with at least one argument. */
752 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
754 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
756 if (!gfc_is_constant_expr (arg
->expr
))
770 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
771 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
776 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
777 if (!gfc_is_constant_expr (c
->expr
))
785 rv
= gfc_constant_ac (e
);
789 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
796 /* Is true if an array reference is followed by a component or substring
799 is_subref_array (gfc_expr
* e
)
804 if (e
->expr_type
!= EXPR_VARIABLE
)
807 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
811 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
813 if (ref
->type
== REF_ARRAY
814 && ref
->u
.ar
.type
!= AR_ELEMENT
)
818 && ref
->type
!= REF_ARRAY
)
825 /* Try to collapse intrinsic expressions. */
828 simplify_intrinsic_op (gfc_expr
*p
, int type
)
831 gfc_expr
*op1
, *op2
, *result
;
833 if (p
->value
.op
.operator == INTRINSIC_USER
)
836 op1
= p
->value
.op
.op1
;
837 op2
= p
->value
.op
.op2
;
838 op
= p
->value
.op
.operator;
840 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
842 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
845 if (!gfc_is_constant_expr (op1
)
846 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
850 p
->value
.op
.op1
= NULL
;
851 p
->value
.op
.op2
= NULL
;
855 case INTRINSIC_PARENTHESES
:
856 result
= gfc_parentheses (op1
);
859 case INTRINSIC_UPLUS
:
860 result
= gfc_uplus (op1
);
863 case INTRINSIC_UMINUS
:
864 result
= gfc_uminus (op1
);
868 result
= gfc_add (op1
, op2
);
871 case INTRINSIC_MINUS
:
872 result
= gfc_subtract (op1
, op2
);
875 case INTRINSIC_TIMES
:
876 result
= gfc_multiply (op1
, op2
);
879 case INTRINSIC_DIVIDE
:
880 result
= gfc_divide (op1
, op2
);
883 case INTRINSIC_POWER
:
884 result
= gfc_power (op1
, op2
);
887 case INTRINSIC_CONCAT
:
888 result
= gfc_concat (op1
, op2
);
892 case INTRINSIC_EQ_OS
:
893 result
= gfc_eq (op1
, op2
, op
);
897 case INTRINSIC_NE_OS
:
898 result
= gfc_ne (op1
, op2
, op
);
902 case INTRINSIC_GT_OS
:
903 result
= gfc_gt (op1
, op2
, op
);
907 case INTRINSIC_GE_OS
:
908 result
= gfc_ge (op1
, op2
, op
);
912 case INTRINSIC_LT_OS
:
913 result
= gfc_lt (op1
, op2
, op
);
917 case INTRINSIC_LE_OS
:
918 result
= gfc_le (op1
, op2
, op
);
922 result
= gfc_not (op1
);
926 result
= gfc_and (op1
, op2
);
930 result
= gfc_or (op1
, op2
);
934 result
= gfc_eqv (op1
, op2
);
938 result
= gfc_neqv (op1
, op2
);
942 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
952 result
->rank
= p
->rank
;
953 result
->where
= p
->where
;
954 gfc_replace_expr (p
, result
);
960 /* Subroutine to simplify constructor expressions. Mutually recursive
961 with gfc_simplify_expr(). */
964 simplify_constructor (gfc_constructor
*c
, int type
)
968 for (; c
; c
= c
->next
)
971 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
972 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
973 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
978 /* Try and simplify a copy. Replace the original if successful
979 but keep going through the constructor at all costs. Not
980 doing so can make a dog's dinner of complicated things. */
981 p
= gfc_copy_expr (c
->expr
);
983 if (gfc_simplify_expr (p
, type
) == FAILURE
)
989 gfc_replace_expr (c
->expr
, p
);
997 /* Pull a single array element out of an array constructor. */
1000 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
1001 gfc_constructor
**rval
)
1003 unsigned long nelemen
;
1015 mpz_init_set_ui (offset
, 0);
1018 mpz_init_set_ui (span
, 1);
1019 for (i
= 0; i
< ar
->dimen
; i
++)
1021 e
= gfc_copy_expr (ar
->start
[i
]);
1022 if (e
->expr_type
!= EXPR_CONSTANT
)
1028 /* Check the bounds. */
1029 if (ar
->as
->upper
[i
]
1030 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
1031 || mpz_cmp (e
->value
.integer
,
1032 ar
->as
->lower
[i
]->value
.integer
) < 0))
1034 gfc_error ("index in dimension %d is out of bounds "
1035 "at %L", i
+ 1, &ar
->c_where
[i
]);
1041 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1042 mpz_mul (delta
, delta
, span
);
1043 mpz_add (offset
, offset
, delta
);
1045 mpz_set_ui (tmp
, 1);
1046 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1047 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1048 mpz_mul (span
, span
, tmp
);
1053 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1076 /* Find a component of a structure constructor. */
1078 static gfc_constructor
*
1079 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1081 gfc_component
*comp
;
1082 gfc_component
*pick
;
1084 comp
= ref
->u
.c
.sym
->components
;
1085 pick
= ref
->u
.c
.component
;
1086 while (comp
!= pick
)
1096 /* Replace an expression with the contents of a constructor, removing
1097 the subobject reference in the process. */
1100 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1106 e
->ref
= p
->ref
->next
;
1107 p
->ref
->next
= NULL
;
1108 gfc_replace_expr (p
, e
);
1112 /* Pull an array section out of an array constructor. */
1115 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1121 long unsigned one
= 1;
1123 mpz_t start
[GFC_MAX_DIMENSIONS
];
1124 mpz_t end
[GFC_MAX_DIMENSIONS
];
1125 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1126 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1127 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1133 gfc_constructor
*cons
;
1134 gfc_constructor
*base
;
1140 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1145 base
= expr
->value
.constructor
;
1146 expr
->value
.constructor
= NULL
;
1148 rank
= ref
->u
.ar
.as
->rank
;
1150 if (expr
->shape
== NULL
)
1151 expr
->shape
= gfc_get_shape (rank
);
1153 mpz_init_set_ui (delta_mpz
, one
);
1154 mpz_init_set_ui (nelts
, one
);
1157 /* Do the initialization now, so that we can cleanup without
1158 keeping track of where we were. */
1159 for (d
= 0; d
< rank
; d
++)
1161 mpz_init (delta
[d
]);
1162 mpz_init (start
[d
]);
1165 mpz_init (stride
[d
]);
1169 /* Build the counters to clock through the array reference. */
1171 for (d
= 0; d
< rank
; d
++)
1173 /* Make this stretch of code easier on the eye! */
1174 begin
= ref
->u
.ar
.start
[d
];
1175 finish
= ref
->u
.ar
.end
[d
];
1176 step
= ref
->u
.ar
.stride
[d
];
1177 lower
= ref
->u
.ar
.as
->lower
[d
];
1178 upper
= ref
->u
.ar
.as
->upper
[d
];
1180 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1184 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1190 gcc_assert (begin
->rank
== 1);
1191 gcc_assert (begin
->shape
);
1193 vecsub
[d
] = begin
->value
.constructor
;
1194 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1195 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1196 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1199 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1201 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1202 || mpz_cmp (c
->expr
->value
.integer
,
1203 lower
->value
.integer
) < 0)
1205 gfc_error ("index in dimension %d is out of bounds "
1206 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1214 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1215 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1216 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1222 /* Obtain the stride. */
1224 mpz_set (stride
[d
], step
->value
.integer
);
1226 mpz_set_ui (stride
[d
], one
);
1228 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1229 mpz_set_ui (stride
[d
], one
);
1231 /* Obtain the start value for the index. */
1233 mpz_set (start
[d
], begin
->value
.integer
);
1235 mpz_set (start
[d
], lower
->value
.integer
);
1237 mpz_set (ctr
[d
], start
[d
]);
1239 /* Obtain the end value for the index. */
1241 mpz_set (end
[d
], finish
->value
.integer
);
1243 mpz_set (end
[d
], upper
->value
.integer
);
1245 /* Separate 'if' because elements sometimes arrive with
1247 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1248 mpz_set (end
[d
], begin
->value
.integer
);
1250 /* Check the bounds. */
1251 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1252 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1253 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1254 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1256 gfc_error ("index in dimension %d is out of bounds "
1257 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1262 /* Calculate the number of elements and the shape. */
1263 mpz_set (tmp_mpz
, stride
[d
]);
1264 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1265 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1266 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1267 mpz_mul (nelts
, nelts
, tmp_mpz
);
1269 /* An element reference reduces the rank of the expression; don't
1270 add anything to the shape array. */
1271 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1272 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1275 /* Calculate the 'stride' (=delta) for conversion of the
1276 counter values into the index along the constructor. */
1277 mpz_set (delta
[d
], delta_mpz
);
1278 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1279 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1280 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1287 /* Now clock through the array reference, calculating the index in
1288 the source constructor and transferring the elements to the new
1290 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1292 if (ref
->u
.ar
.offset
)
1293 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1295 mpz_init_set_ui (ptr
, 0);
1298 for (d
= 0; d
< rank
; d
++)
1300 mpz_set (tmp_mpz
, ctr
[d
]);
1301 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1302 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1303 mpz_add (ptr
, ptr
, tmp_mpz
);
1305 if (!incr_ctr
) continue;
1307 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1309 gcc_assert(vecsub
[d
]);
1311 if (!vecsub
[d
]->next
)
1312 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1315 vecsub
[d
] = vecsub
[d
]->next
;
1318 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1322 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1324 if (mpz_cmp_ui (stride
[d
], 0) > 0
1325 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1326 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1327 mpz_set (ctr
[d
], start
[d
]);
1333 /* There must be a better way of dealing with negative strides
1334 than resetting the index and the constructor pointer! */
1335 if (mpz_cmp (ptr
, index
) < 0)
1337 mpz_set_ui (index
, 0);
1341 while (mpz_cmp (ptr
, index
) > 0)
1343 mpz_add_ui (index
, index
, one
);
1347 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1355 mpz_clear (delta_mpz
);
1356 mpz_clear (tmp_mpz
);
1358 for (d
= 0; d
< rank
; d
++)
1360 mpz_clear (delta
[d
]);
1361 mpz_clear (start
[d
]);
1364 mpz_clear (stride
[d
]);
1366 gfc_free_constructor (base
);
1370 /* Pull a substring out of an expression. */
1373 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1380 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1381 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1384 *newp
= gfc_copy_expr (p
);
1385 gfc_free ((*newp
)->value
.character
.string
);
1387 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1388 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1389 length
= end
- start
+ 1;
1391 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1392 (*newp
)->value
.character
.length
= length
;
1393 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1400 /* Simplify a subobject reference of a constructor. This occurs when
1401 parameter variable values are substituted. */
1404 simplify_const_ref (gfc_expr
*p
)
1406 gfc_constructor
*cons
;
1411 switch (p
->ref
->type
)
1414 switch (p
->ref
->u
.ar
.type
)
1417 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1424 remove_subobject_ref (p
, cons
);
1428 if (find_array_section (p
, p
->ref
) == FAILURE
)
1430 p
->ref
->u
.ar
.type
= AR_FULL
;
1435 if (p
->ref
->next
!= NULL
1436 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1438 cons
= p
->value
.constructor
;
1439 for (; cons
; cons
= cons
->next
)
1441 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1442 simplify_const_ref (cons
->expr
);
1445 gfc_free_ref_list (p
->ref
);
1456 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1457 remove_subobject_ref (p
, cons
);
1461 if (find_substring_ref (p
, &newp
) == FAILURE
)
1464 gfc_replace_expr (p
, newp
);
1465 gfc_free_ref_list (p
->ref
);
1475 /* Simplify a chain of references. */
1478 simplify_ref_chain (gfc_ref
*ref
, int type
)
1482 for (; ref
; ref
= ref
->next
)
1487 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1489 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1491 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1493 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1499 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1501 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1513 /* Try to substitute the value of a parameter variable. */
1516 simplify_parameter_variable (gfc_expr
*p
, int type
)
1521 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1527 /* Do not copy subobject refs for constant. */
1528 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1529 e
->ref
= copy_ref (p
->ref
);
1530 t
= gfc_simplify_expr (e
, type
);
1532 /* Only use the simplification if it eliminated all subobject references. */
1533 if (t
== SUCCESS
&& !e
->ref
)
1534 gfc_replace_expr (p
, e
);
1541 /* Given an expression, simplify it by collapsing constant
1542 expressions. Most simplification takes place when the expression
1543 tree is being constructed. If an intrinsic function is simplified
1544 at some point, we get called again to collapse the result against
1547 We work by recursively simplifying expression nodes, simplifying
1548 intrinsic functions where possible, which can lead to further
1549 constant collapsing. If an operator has constant operand(s), we
1550 rip the expression apart, and rebuild it, hoping that it becomes
1553 The expression type is defined for:
1554 0 Basic expression parsing
1555 1 Simplifying array constructors -- will substitute
1557 Returns FAILURE on error, SUCCESS otherwise.
1558 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1561 gfc_simplify_expr (gfc_expr
*p
, int type
)
1563 gfc_actual_arglist
*ap
;
1568 switch (p
->expr_type
)
1575 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1576 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1579 if (p
->value
.function
.isym
!= NULL
1580 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1585 case EXPR_SUBSTRING
:
1586 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1589 if (gfc_is_constant_expr (p
))
1594 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1596 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1597 start
--; /* Convert from one-based to zero-based. */
1602 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1603 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1605 end
= p
->value
.character
.length
;
1607 s
= gfc_getmem (end
- start
+ 2);
1608 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1609 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1610 gfc_free (p
->value
.character
.string
);
1611 p
->value
.character
.string
= s
;
1612 p
->value
.character
.length
= end
- start
;
1613 p
->ts
.cl
= gfc_get_charlen ();
1614 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1615 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1616 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1617 gfc_free_ref_list (p
->ref
);
1619 p
->expr_type
= EXPR_CONSTANT
;
1624 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1629 /* Only substitute array parameter variables if we are in an
1630 initialization expression, or we want a subsection. */
1631 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1632 && (gfc_init_expr
|| p
->ref
1633 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1635 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1642 gfc_simplify_iterator_var (p
);
1645 /* Simplify subcomponent references. */
1646 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1651 case EXPR_STRUCTURE
:
1653 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1656 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1659 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1660 && p
->ref
->u
.ar
.type
== AR_FULL
)
1661 gfc_expand_constructor (p
);
1663 if (simplify_const_ref (p
) == FAILURE
)
1673 /* Returns the type of an expression with the exception that iterator
1674 variables are automatically integers no matter what else they may
1680 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1687 /* Check an intrinsic arithmetic operation to see if it is consistent
1688 with some type of expression. */
1690 static try check_init_expr (gfc_expr
*);
1693 /* Scalarize an expression for an elemental intrinsic call. */
1696 scalarize_intrinsic_call (gfc_expr
*e
)
1698 gfc_actual_arglist
*a
, *b
;
1699 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1700 gfc_expr
*expr
, *old
;
1703 old
= gfc_copy_expr (e
);
1705 /* Assume that the old expression carries the type information and
1706 that the first arg carries all the shape information. */
1707 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1708 gfc_free_constructor (expr
->value
.constructor
);
1709 expr
->value
.constructor
= NULL
;
1712 expr
->expr_type
= EXPR_ARRAY
;
1714 /* Copy the array argument constructors into an array, with nulls
1717 a
= old
->value
.function
.actual
;
1718 for (; a
; a
= a
->next
)
1720 /* Check that this is OK for an initialization expression. */
1721 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1725 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1727 rank
[n
] = a
->expr
->rank
;
1728 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1729 args
[n
] = gfc_copy_constructor (ctor
);
1731 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1734 rank
[n
] = a
->expr
->rank
;
1737 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1744 for (i
= 1; i
< n
; i
++)
1745 if (rank
[i
] && rank
[i
] != rank
[0])
1748 /* Using the first argument as the master, step through the array
1749 calling the function for each element and advancing the array
1750 constructors together. */
1753 for (; ctor
; ctor
= ctor
->next
)
1755 if (expr
->value
.constructor
== NULL
)
1756 expr
->value
.constructor
1757 = new_ctor
= gfc_get_constructor ();
1760 new_ctor
->next
= gfc_get_constructor ();
1761 new_ctor
= new_ctor
->next
;
1763 new_ctor
->expr
= gfc_copy_expr (old
);
1764 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1766 b
= old
->value
.function
.actual
;
1767 for (i
= 0; i
< n
; i
++)
1770 new_ctor
->expr
->value
.function
.actual
1771 = a
= gfc_get_actual_arglist ();
1774 a
->next
= gfc_get_actual_arglist ();
1778 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1780 a
->expr
= gfc_copy_expr (b
->expr
);
1785 /* Simplify the function calls. */
1786 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1789 for (i
= 0; i
< n
; i
++)
1791 args
[i
] = args
[i
]->next
;
1793 for (i
= 1; i
< n
; i
++)
1794 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1795 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1801 gfc_free_expr (old
);
1805 gfc_error_now ("elemental function arguments at %C are not compliant");
1808 gfc_free_expr (expr
);
1809 gfc_free_expr (old
);
1815 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1817 gfc_expr
*op1
= e
->value
.op
.op1
;
1818 gfc_expr
*op2
= e
->value
.op
.op2
;
1820 if ((*check_function
) (op1
) == FAILURE
)
1823 switch (e
->value
.op
.operator)
1825 case INTRINSIC_UPLUS
:
1826 case INTRINSIC_UMINUS
:
1827 if (!numeric_type (et0 (op1
)))
1832 case INTRINSIC_EQ_OS
:
1834 case INTRINSIC_NE_OS
:
1836 case INTRINSIC_GT_OS
:
1838 case INTRINSIC_GE_OS
:
1840 case INTRINSIC_LT_OS
:
1842 case INTRINSIC_LE_OS
:
1843 if ((*check_function
) (op2
) == FAILURE
)
1846 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1847 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1849 gfc_error ("Numeric or CHARACTER operands are required in "
1850 "expression at %L", &e
->where
);
1855 case INTRINSIC_PLUS
:
1856 case INTRINSIC_MINUS
:
1857 case INTRINSIC_TIMES
:
1858 case INTRINSIC_DIVIDE
:
1859 case INTRINSIC_POWER
:
1860 if ((*check_function
) (op2
) == FAILURE
)
1863 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1866 if (e
->value
.op
.operator == INTRINSIC_POWER
1867 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1869 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1870 "exponent in an initialization "
1871 "expression at %L", &op2
->where
)
1878 case INTRINSIC_CONCAT
:
1879 if ((*check_function
) (op2
) == FAILURE
)
1882 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1884 gfc_error ("Concatenation operator in expression at %L "
1885 "must have two CHARACTER operands", &op1
->where
);
1889 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1891 gfc_error ("Concat operator at %L must concatenate strings of the "
1892 "same kind", &e
->where
);
1899 if (et0 (op1
) != BT_LOGICAL
)
1901 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1902 "operand", &op1
->where
);
1911 case INTRINSIC_NEQV
:
1912 if ((*check_function
) (op2
) == FAILURE
)
1915 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1917 gfc_error ("LOGICAL operands are required in expression at %L",
1924 case INTRINSIC_PARENTHESES
:
1928 gfc_error ("Only intrinsic operators can be used in expression at %L",
1936 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1943 check_init_expr_arguments (gfc_expr
*e
)
1945 gfc_actual_arglist
*ap
;
1947 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1948 if (check_init_expr (ap
->expr
) == FAILURE
)
1954 /* F95, 7.1.6.1, Initialization expressions, (7)
1955 F2003, 7.1.7 Initialization expression, (8) */
1958 check_inquiry (gfc_expr
*e
, int not_restricted
)
1961 const char *const *functions
;
1963 static const char *const inquiry_func_f95
[] = {
1964 "lbound", "shape", "size", "ubound",
1965 "bit_size", "len", "kind",
1966 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1967 "precision", "radix", "range", "tiny",
1971 static const char *const inquiry_func_f2003
[] = {
1972 "lbound", "shape", "size", "ubound",
1973 "bit_size", "len", "kind",
1974 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1975 "precision", "radix", "range", "tiny",
1980 gfc_actual_arglist
*ap
;
1982 if (!e
->value
.function
.isym
1983 || !e
->value
.function
.isym
->inquiry
)
1986 /* An undeclared parameter will get us here (PR25018). */
1987 if (e
->symtree
== NULL
)
1990 name
= e
->symtree
->n
.sym
->name
;
1992 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1993 ? inquiry_func_f2003
: inquiry_func_f95
;
1995 for (i
= 0; functions
[i
]; i
++)
1996 if (strcmp (functions
[i
], name
) == 0)
1999 if (functions
[i
] == NULL
)
2002 /* At this point we have an inquiry function with a variable argument. The
2003 type of the variable might be undefined, but we need it now, because the
2004 arguments of these functions are not allowed to be undefined. */
2006 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2011 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2013 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2014 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2018 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2021 /* Assumed character length will not reduce to a constant expression
2022 with LEN, as required by the standard. */
2023 if (i
== 5 && not_restricted
2024 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2025 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2027 gfc_error ("Assumed character length variable '%s' in constant "
2028 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2031 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2039 /* F95, 7.1.6.1, Initialization expressions, (5)
2040 F2003, 7.1.7 Initialization expression, (5) */
2043 check_transformational (gfc_expr
*e
)
2045 static const char * const trans_func_f95
[] = {
2046 "repeat", "reshape", "selected_int_kind",
2047 "selected_real_kind", "transfer", "trim", NULL
2053 if (!e
->value
.function
.isym
2054 || !e
->value
.function
.isym
->transformational
)
2057 name
= e
->symtree
->n
.sym
->name
;
2059 /* NULL() is dealt with below. */
2060 if (strcmp ("null", name
) == 0)
2063 for (i
= 0; trans_func_f95
[i
]; i
++)
2064 if (strcmp (trans_func_f95
[i
], name
) == 0)
2067 /* FIXME, F2003: implement translation of initialization
2068 expressions before enabling this check. For F95, error
2069 out if the transformational function is not in the list. */
2071 if (trans_func_f95
[i
] == NULL
2072 && gfc_notify_std (GFC_STD_F2003
,
2073 "transformational intrinsic '%s' at %L is not permitted "
2074 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2077 if (trans_func_f95
[i
] == NULL
)
2079 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2080 "in an initialization expression", name
, &e
->where
);
2085 return check_init_expr_arguments (e
);
2089 /* F95, 7.1.6.1, Initialization expressions, (6)
2090 F2003, 7.1.7 Initialization expression, (6) */
2093 check_null (gfc_expr
*e
)
2095 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2098 return check_init_expr_arguments (e
);
2103 check_elemental (gfc_expr
*e
)
2105 if (!e
->value
.function
.isym
2106 || !e
->value
.function
.isym
->elemental
)
2109 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2110 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2111 "nonstandard initialization expression at %L",
2112 &e
->where
) == FAILURE
)
2115 return check_init_expr_arguments (e
);
2120 check_conversion (gfc_expr
*e
)
2122 if (!e
->value
.function
.isym
2123 || !e
->value
.function
.isym
->conversion
)
2126 return check_init_expr_arguments (e
);
2130 /* Verify that an expression is an initialization expression. A side
2131 effect is that the expression tree is reduced to a single constant
2132 node if all goes well. This would normally happen when the
2133 expression is constructed but function references are assumed to be
2134 intrinsics in the context of initialization expressions. If
2135 FAILURE is returned an error message has been generated. */
2138 check_init_expr (gfc_expr
*e
)
2142 gfc_intrinsic_sym
*isym
;
2147 switch (e
->expr_type
)
2150 t
= check_intrinsic_op (e
, check_init_expr
);
2152 t
= gfc_simplify_expr (e
, 0);
2159 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2161 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2163 gfc_error ("Function '%s' in initialization expression at %L "
2164 "must be an intrinsic or a specification function",
2165 e
->symtree
->n
.sym
->name
, &e
->where
);
2169 if ((m
= check_conversion (e
)) == MATCH_NO
2170 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2171 && (m
= check_null (e
)) == MATCH_NO
2172 && (m
= check_transformational (e
)) == MATCH_NO
2173 && (m
= check_elemental (e
)) == MATCH_NO
)
2175 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2176 "in an initialization expression",
2177 e
->symtree
->n
.sym
->name
, &e
->where
);
2181 /* Try to scalarize an elemental intrinsic function that has an
2183 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2184 if (isym
&& isym
->elemental
2185 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2187 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2193 t
= gfc_simplify_expr (e
, 0);
2200 if (gfc_check_iter_variable (e
) == SUCCESS
)
2203 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2205 /* A PARAMETER shall not be used to define itself, i.e.
2206 REAL, PARAMETER :: x = transfer(0, x)
2208 if (!e
->symtree
->n
.sym
->value
)
2210 gfc_error("PARAMETER '%s' is used at %L before its definition "
2211 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2215 t
= simplify_parameter_variable (e
, 0);
2220 if (gfc_in_match_data ())
2225 if (e
->symtree
->n
.sym
->as
)
2227 switch (e
->symtree
->n
.sym
->as
->type
)
2229 case AS_ASSUMED_SIZE
:
2230 gfc_error ("Assumed size array '%s' at %L is not permitted "
2231 "in an initialization expression",
2232 e
->symtree
->n
.sym
->name
, &e
->where
);
2235 case AS_ASSUMED_SHAPE
:
2236 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2237 "in an initialization expression",
2238 e
->symtree
->n
.sym
->name
, &e
->where
);
2242 gfc_error ("Deferred array '%s' at %L is not permitted "
2243 "in an initialization expression",
2244 e
->symtree
->n
.sym
->name
, &e
->where
);
2248 gfc_error ("Array '%s' at %L is a variable, which does "
2249 "not reduce to a constant expression",
2250 e
->symtree
->n
.sym
->name
, &e
->where
);
2258 gfc_error ("Parameter '%s' at %L has not been declared or is "
2259 "a variable, which does not reduce to a constant "
2260 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2269 case EXPR_SUBSTRING
:
2270 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2274 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2276 t
= gfc_simplify_expr (e
, 0);
2280 case EXPR_STRUCTURE
:
2284 t
= gfc_check_constructor (e
, check_init_expr
);
2288 t
= gfc_check_constructor (e
, check_init_expr
);
2292 t
= gfc_expand_constructor (e
);
2296 t
= gfc_check_constructor_type (e
);
2300 gfc_internal_error ("check_init_expr(): Unknown expression type");
2307 /* Match an initialization expression. We work by first matching an
2308 expression, then reducing it to a constant. */
2311 gfc_match_init_expr (gfc_expr
**result
)
2317 m
= gfc_match_expr (&expr
);
2322 t
= gfc_resolve_expr (expr
);
2324 t
= check_init_expr (expr
);
2329 gfc_free_expr (expr
);
2333 if (expr
->expr_type
== EXPR_ARRAY
2334 && (gfc_check_constructor_type (expr
) == FAILURE
2335 || gfc_expand_constructor (expr
) == FAILURE
))
2337 gfc_free_expr (expr
);
2341 /* Not all inquiry functions are simplified to constant expressions
2342 so it is necessary to call check_inquiry again. */
2343 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2344 && !gfc_in_match_data ())
2346 gfc_error ("Initialization expression didn't reduce %C");
2356 static try check_restricted (gfc_expr
*);
2358 /* Given an actual argument list, test to see that each argument is a
2359 restricted expression and optionally if the expression type is
2360 integer or character. */
2363 restricted_args (gfc_actual_arglist
*a
)
2365 for (; a
; a
= a
->next
)
2367 if (check_restricted (a
->expr
) == FAILURE
)
2375 /************* Restricted/specification expressions *************/
2378 /* Make sure a non-intrinsic function is a specification function. */
2381 external_spec_function (gfc_expr
*e
)
2385 f
= e
->value
.function
.esym
;
2387 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2389 gfc_error ("Specification function '%s' at %L cannot be a statement "
2390 "function", f
->name
, &e
->where
);
2394 if (f
->attr
.proc
== PROC_INTERNAL
)
2396 gfc_error ("Specification function '%s' at %L cannot be an internal "
2397 "function", f
->name
, &e
->where
);
2401 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2403 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2408 if (f
->attr
.recursive
)
2410 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2411 f
->name
, &e
->where
);
2415 return restricted_args (e
->value
.function
.actual
);
2419 /* Check to see that a function reference to an intrinsic is a
2420 restricted expression. */
2423 restricted_intrinsic (gfc_expr
*e
)
2425 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2426 if (check_inquiry (e
, 0) == MATCH_YES
)
2429 return restricted_args (e
->value
.function
.actual
);
2433 /* Verify that an expression is a restricted expression. Like its
2434 cousin check_init_expr(), an error message is generated if we
2438 check_restricted (gfc_expr
*e
)
2446 switch (e
->expr_type
)
2449 t
= check_intrinsic_op (e
, check_restricted
);
2451 t
= gfc_simplify_expr (e
, 0);
2456 t
= e
->value
.function
.esym
? external_spec_function (e
)
2457 : restricted_intrinsic (e
);
2461 sym
= e
->symtree
->n
.sym
;
2464 /* If a dummy argument appears in a context that is valid for a
2465 restricted expression in an elemental procedure, it will have
2466 already been simplified away once we get here. Therefore we
2467 don't need to jump through hoops to distinguish valid from
2469 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2470 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2472 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2473 sym
->name
, &e
->where
);
2477 if (sym
->attr
.optional
)
2479 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2480 sym
->name
, &e
->where
);
2484 if (sym
->attr
.intent
== INTENT_OUT
)
2486 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2487 sym
->name
, &e
->where
);
2491 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2492 processed in resolve.c(resolve_formal_arglist). This is done so
2493 that host associated dummy array indices are accepted (PR23446).
2494 This mechanism also does the same for the specification expressions
2495 of array-valued functions. */
2496 if (sym
->attr
.in_common
2497 || sym
->attr
.use_assoc
2499 || sym
->ns
!= gfc_current_ns
2500 || (sym
->ns
->proc_name
!= NULL
2501 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2502 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2508 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2509 sym
->name
, &e
->where
);
2518 case EXPR_SUBSTRING
:
2519 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2523 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2525 t
= gfc_simplify_expr (e
, 0);
2529 case EXPR_STRUCTURE
:
2530 t
= gfc_check_constructor (e
, check_restricted
);
2534 t
= gfc_check_constructor (e
, check_restricted
);
2538 gfc_internal_error ("check_restricted(): Unknown expression type");
2545 /* Check to see that an expression is a specification expression. If
2546 we return FAILURE, an error has been generated. */
2549 gfc_specification_expr (gfc_expr
*e
)
2555 if (e
->ts
.type
!= BT_INTEGER
)
2557 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2561 if (e
->expr_type
== EXPR_FUNCTION
2562 && !e
->value
.function
.isym
2563 && !e
->value
.function
.esym
2564 && !gfc_pure (e
->symtree
->n
.sym
))
2566 gfc_error ("Function '%s' at %L must be PURE",
2567 e
->symtree
->n
.sym
->name
, &e
->where
);
2568 /* Prevent repeat error messages. */
2569 e
->symtree
->n
.sym
->attr
.pure
= 1;
2575 gfc_error ("Expression at %L must be scalar", &e
->where
);
2579 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2582 return check_restricted (e
);
2586 /************** Expression conformance checks. *************/
2588 /* Given two expressions, make sure that the arrays are conformable. */
2591 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2593 int op1_flag
, op2_flag
, d
;
2594 mpz_t op1_size
, op2_size
;
2597 if (op1
->rank
== 0 || op2
->rank
== 0)
2600 if (op1
->rank
!= op2
->rank
)
2602 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2603 op1
->rank
, op2
->rank
, &op1
->where
);
2609 for (d
= 0; d
< op1
->rank
; d
++)
2611 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2612 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2614 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2616 gfc_error ("Different shape for %s at %L on dimension %d "
2617 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2618 (int) mpz_get_si (op1_size
),
2619 (int) mpz_get_si (op2_size
));
2625 mpz_clear (op1_size
);
2627 mpz_clear (op2_size
);
2637 /* Given an assignable expression and an arbitrary expression, make
2638 sure that the assignment can take place. */
2641 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2647 sym
= lvalue
->symtree
->n
.sym
;
2649 /* Check INTENT(IN), unless the object itself is the component or
2650 sub-component of a pointer. */
2651 has_pointer
= sym
->attr
.pointer
;
2653 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2654 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2660 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2662 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2663 sym
->name
, &lvalue
->where
);
2667 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2668 variable local to a function subprogram. Its existence begins when
2669 execution of the function is initiated and ends when execution of the
2670 function is terminated...
2671 Therefore, the left hand side is no longer a variable, when it is: */
2672 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2673 && !sym
->attr
.external
)
2678 /* (i) Use associated; */
2679 if (sym
->attr
.use_assoc
)
2682 /* (ii) The assignment is in the main program; or */
2683 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2686 /* (iii) A module or internal procedure... */
2687 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2688 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2689 && gfc_current_ns
->parent
2690 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2691 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2692 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2694 /* ... that is not a function... */
2695 if (!gfc_current_ns
->proc_name
->attr
.function
)
2698 /* ... or is not an entry and has a different name. */
2699 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2705 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2710 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2712 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2713 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2717 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2719 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2724 if (rvalue
->expr_type
== EXPR_NULL
)
2726 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2727 && lvalue
->symtree
->n
.sym
->attr
.data
)
2731 gfc_error ("NULL appears on right-hand side in assignment at %L",
2737 if (sym
->attr
.cray_pointee
2738 && lvalue
->ref
!= NULL
2739 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2740 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2742 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2743 "is illegal", &lvalue
->where
);
2747 /* This is possibly a typo: x = f() instead of x => f(). */
2748 if (gfc_option
.warn_surprising
2749 && rvalue
->expr_type
== EXPR_FUNCTION
2750 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2751 gfc_warning ("POINTER valued function appears on right-hand side of "
2752 "assignment at %L", &rvalue
->where
);
2754 /* Check size of array assignments. */
2755 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2756 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2759 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2760 && lvalue
->symtree
->n
.sym
->attr
.data
2761 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2762 "initialize non-integer variable '%s'",
2763 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2766 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2767 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2768 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2769 &rvalue
->where
) == FAILURE
)
2772 /* Handle the case of a BOZ literal on the RHS. */
2773 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2776 if (gfc_option
.warn_surprising
)
2777 gfc_warning ("BOZ literal at %L is bitwise transferred "
2778 "non-integer symbol '%s'", &rvalue
->where
,
2779 lvalue
->symtree
->n
.sym
->name
);
2780 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2782 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2784 if (rc
== ARITH_UNDERFLOW
)
2785 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2786 ". This check can be disabled with the option "
2787 "-fno-range-check", &rvalue
->where
);
2788 else if (rc
== ARITH_OVERFLOW
)
2789 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2790 ". This check can be disabled with the option "
2791 "-fno-range-check", &rvalue
->where
);
2792 else if (rc
== ARITH_NAN
)
2793 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2794 ". This check can be disabled with the option "
2795 "-fno-range-check", &rvalue
->where
);
2800 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2805 /* Numeric can be converted to any other numeric. And Hollerith can be
2806 converted to any other type. */
2807 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2808 || rvalue
->ts
.type
== BT_HOLLERITH
)
2811 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2814 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2815 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2816 gfc_typename (&lvalue
->ts
));
2821 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2825 /* Check that a pointer assignment is OK. We first check lvalue, and
2826 we only check rvalue if it's not an assignment to NULL() or a
2827 NULLIFY statement. */
2830 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2832 symbol_attribute attr
;
2835 int pointer
, check_intent_in
;
2837 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2839 gfc_error ("Pointer assignment target is not a POINTER at %L",
2844 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2845 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2847 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2848 "l-value since it is a procedure",
2849 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2854 /* Check INTENT(IN), unless the object itself is the component or
2855 sub-component of a pointer. */
2856 check_intent_in
= 1;
2857 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2859 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2862 check_intent_in
= 0;
2864 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2868 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2870 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2871 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2877 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2881 is_pure
= gfc_pure (NULL
);
2883 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2884 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2886 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2890 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2891 kind, etc for lvalue and rvalue must match, and rvalue must be a
2892 pure variable if we're in a pure function. */
2893 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2896 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2898 gfc_error ("Different types in pointer assignment at %L",
2903 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2905 gfc_error ("Different kind type parameters in pointer "
2906 "assignment at %L", &lvalue
->where
);
2910 if (lvalue
->rank
!= rvalue
->rank
)
2912 gfc_error ("Different ranks in pointer assignment at %L",
2917 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2918 if (rvalue
->expr_type
== EXPR_NULL
)
2921 if (lvalue
->ts
.type
== BT_CHARACTER
2922 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2923 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2924 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2925 rvalue
->ts
.cl
->length
)) == 1)
2927 gfc_error ("Different character lengths in pointer "
2928 "assignment at %L", &lvalue
->where
);
2932 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2933 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2935 attr
= gfc_expr_attr (rvalue
);
2936 if (!attr
.target
&& !attr
.pointer
)
2938 gfc_error ("Pointer assignment target is neither TARGET "
2939 "nor POINTER at %L", &rvalue
->where
);
2943 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2945 gfc_error ("Bad target in pointer assignment in PURE "
2946 "procedure at %L", &rvalue
->where
);
2949 if (gfc_has_vector_index (rvalue
))
2951 gfc_error ("Pointer assignment with vector subscript "
2952 "on rhs at %L", &rvalue
->where
);
2956 if (attr
.protected && attr
.use_assoc
)
2958 gfc_error ("Pointer assigment target has PROTECTED "
2959 "attribute at %L", &rvalue
->where
);
2967 /* Relative of gfc_check_assign() except that the lvalue is a single
2968 symbol. Used for initialization assignments. */
2971 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2976 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2978 lvalue
.expr_type
= EXPR_VARIABLE
;
2979 lvalue
.ts
= sym
->ts
;
2981 lvalue
.rank
= sym
->as
->rank
;
2982 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2983 lvalue
.symtree
->n
.sym
= sym
;
2984 lvalue
.where
= sym
->declared_at
;
2986 if (sym
->attr
.pointer
)
2987 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2989 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2991 gfc_free (lvalue
.symtree
);
2997 /* Get an expression for a default initializer. */
3000 gfc_default_initializer (gfc_typespec
*ts
)
3002 gfc_constructor
*tail
;
3006 /* See if we have a default initializer. */
3007 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3008 if (c
->initializer
|| c
->allocatable
)
3014 /* Build the constructor. */
3015 init
= gfc_get_expr ();
3016 init
->expr_type
= EXPR_STRUCTURE
;
3018 init
->where
= ts
->derived
->declared_at
;
3021 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3024 init
->value
.constructor
= tail
= gfc_get_constructor ();
3027 tail
->next
= gfc_get_constructor ();
3032 tail
->expr
= gfc_copy_expr (c
->initializer
);
3036 tail
->expr
= gfc_get_expr ();
3037 tail
->expr
->expr_type
= EXPR_NULL
;
3038 tail
->expr
->ts
= c
->ts
;
3045 /* Given a symbol, create an expression node with that symbol as a
3046 variable. If the symbol is array valued, setup a reference of the
3050 gfc_get_variable_expr (gfc_symtree
*var
)
3054 e
= gfc_get_expr ();
3055 e
->expr_type
= EXPR_VARIABLE
;
3057 e
->ts
= var
->n
.sym
->ts
;
3059 if (var
->n
.sym
->as
!= NULL
)
3061 e
->rank
= var
->n
.sym
->as
->rank
;
3062 e
->ref
= gfc_get_ref ();
3063 e
->ref
->type
= REF_ARRAY
;
3064 e
->ref
->u
.ar
.type
= AR_FULL
;
3071 /* General expression traversal function. */
3074 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3075 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3080 gfc_actual_arglist
*args
;
3087 if ((*func
) (expr
, sym
, &f
))
3090 if (expr
->ts
.type
== BT_CHARACTER
3092 && expr
->ts
.cl
->length
3093 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3094 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3097 switch (expr
->expr_type
)
3100 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3102 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3110 case EXPR_SUBSTRING
:
3113 case EXPR_STRUCTURE
:
3115 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3117 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3121 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3123 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3125 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3127 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3134 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3136 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3152 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3154 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3156 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3158 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3164 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3166 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3171 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3172 && ref
->u
.c
.component
->ts
.cl
3173 && ref
->u
.c
.component
->ts
.cl
->length
3174 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3176 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3180 if (ref
->u
.c
.component
->as
)
3181 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3183 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3186 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3200 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3203 expr_set_symbols_referenced (gfc_expr
*expr
,
3204 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3205 int *f ATTRIBUTE_UNUSED
)
3207 if (expr
->expr_type
!= EXPR_VARIABLE
)
3209 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3214 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3216 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);