1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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. */
168 if (e
->representation
.string
)
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
)
404 switch (q
->expr_type
)
407 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
409 memcpy (s
, p
->value
.character
.string
,
410 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 c
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= c
;
419 memcpy (c
, 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
446 = gfc_char_to_widechar (q
->representation
.string
);
449 s
= gfc_get_wide_string (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) * sizeof (gfc_char_t
));
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
)
1027 /* Check the bounds. */
1028 if ((ar
->as
->upper
[i
]
1029 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1030 && mpz_cmp (e
->value
.integer
,
1031 ar
->as
->upper
[i
]->value
.integer
) > 0)
1033 (ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1034 && mpz_cmp (e
->value
.integer
,
1035 ar
->as
->lower
[i
]->value
.integer
) < 0))
1037 gfc_error ("Index in dimension %d is out of bounds "
1038 "at %L", i
+ 1, &ar
->c_where
[i
]);
1044 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1045 mpz_mul (delta
, delta
, span
);
1046 mpz_add (offset
, offset
, delta
);
1048 mpz_set_ui (tmp
, 1);
1049 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1050 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1051 mpz_mul (span
, span
, tmp
);
1054 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1080 /* Find a component of a structure constructor. */
1082 static gfc_constructor
*
1083 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1085 gfc_component
*comp
;
1086 gfc_component
*pick
;
1088 comp
= ref
->u
.c
.sym
->components
;
1089 pick
= ref
->u
.c
.component
;
1090 while (comp
!= pick
)
1100 /* Replace an expression with the contents of a constructor, removing
1101 the subobject reference in the process. */
1104 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1110 e
->ref
= p
->ref
->next
;
1111 p
->ref
->next
= NULL
;
1112 gfc_replace_expr (p
, e
);
1116 /* Pull an array section out of an array constructor. */
1119 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1125 long unsigned one
= 1;
1127 mpz_t start
[GFC_MAX_DIMENSIONS
];
1128 mpz_t end
[GFC_MAX_DIMENSIONS
];
1129 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1130 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1131 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1137 gfc_constructor
*cons
;
1138 gfc_constructor
*base
;
1144 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1149 base
= expr
->value
.constructor
;
1150 expr
->value
.constructor
= NULL
;
1152 rank
= ref
->u
.ar
.as
->rank
;
1154 if (expr
->shape
== NULL
)
1155 expr
->shape
= gfc_get_shape (rank
);
1157 mpz_init_set_ui (delta_mpz
, one
);
1158 mpz_init_set_ui (nelts
, one
);
1161 /* Do the initialization now, so that we can cleanup without
1162 keeping track of where we were. */
1163 for (d
= 0; d
< rank
; d
++)
1165 mpz_init (delta
[d
]);
1166 mpz_init (start
[d
]);
1169 mpz_init (stride
[d
]);
1173 /* Build the counters to clock through the array reference. */
1175 for (d
= 0; d
< rank
; d
++)
1177 /* Make this stretch of code easier on the eye! */
1178 begin
= ref
->u
.ar
.start
[d
];
1179 finish
= ref
->u
.ar
.end
[d
];
1180 step
= ref
->u
.ar
.stride
[d
];
1181 lower
= ref
->u
.ar
.as
->lower
[d
];
1182 upper
= ref
->u
.ar
.as
->upper
[d
];
1184 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1188 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1194 gcc_assert (begin
->rank
== 1);
1195 gcc_assert (begin
->shape
);
1197 vecsub
[d
] = begin
->value
.constructor
;
1198 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1199 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1200 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1203 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1205 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1206 || mpz_cmp (c
->expr
->value
.integer
,
1207 lower
->value
.integer
) < 0)
1209 gfc_error ("index in dimension %d is out of bounds "
1210 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1218 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1219 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1220 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1226 /* Obtain the stride. */
1228 mpz_set (stride
[d
], step
->value
.integer
);
1230 mpz_set_ui (stride
[d
], one
);
1232 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1233 mpz_set_ui (stride
[d
], one
);
1235 /* Obtain the start value for the index. */
1237 mpz_set (start
[d
], begin
->value
.integer
);
1239 mpz_set (start
[d
], lower
->value
.integer
);
1241 mpz_set (ctr
[d
], start
[d
]);
1243 /* Obtain the end value for the index. */
1245 mpz_set (end
[d
], finish
->value
.integer
);
1247 mpz_set (end
[d
], upper
->value
.integer
);
1249 /* Separate 'if' because elements sometimes arrive with
1251 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1252 mpz_set (end
[d
], begin
->value
.integer
);
1254 /* Check the bounds. */
1255 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1256 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1257 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1258 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1260 gfc_error ("index in dimension %d is out of bounds "
1261 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1266 /* Calculate the number of elements and the shape. */
1267 mpz_set (tmp_mpz
, stride
[d
]);
1268 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1269 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1270 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1271 mpz_mul (nelts
, nelts
, tmp_mpz
);
1273 /* An element reference reduces the rank of the expression; don't
1274 add anything to the shape array. */
1275 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1276 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1279 /* Calculate the 'stride' (=delta) for conversion of the
1280 counter values into the index along the constructor. */
1281 mpz_set (delta
[d
], delta_mpz
);
1282 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1283 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1284 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1291 /* Now clock through the array reference, calculating the index in
1292 the source constructor and transferring the elements to the new
1294 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1296 if (ref
->u
.ar
.offset
)
1297 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1299 mpz_init_set_ui (ptr
, 0);
1302 for (d
= 0; d
< rank
; d
++)
1304 mpz_set (tmp_mpz
, ctr
[d
]);
1305 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1306 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1307 mpz_add (ptr
, ptr
, tmp_mpz
);
1309 if (!incr_ctr
) continue;
1311 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1313 gcc_assert(vecsub
[d
]);
1315 if (!vecsub
[d
]->next
)
1316 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1319 vecsub
[d
] = vecsub
[d
]->next
;
1322 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1326 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1328 if (mpz_cmp_ui (stride
[d
], 0) > 0
1329 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1330 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1331 mpz_set (ctr
[d
], start
[d
]);
1337 /* There must be a better way of dealing with negative strides
1338 than resetting the index and the constructor pointer! */
1339 if (mpz_cmp (ptr
, index
) < 0)
1341 mpz_set_ui (index
, 0);
1345 while (cons
&& cons
->next
&& mpz_cmp (ptr
, index
) > 0)
1347 mpz_add_ui (index
, index
, one
);
1351 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1359 mpz_clear (delta_mpz
);
1360 mpz_clear (tmp_mpz
);
1362 for (d
= 0; d
< rank
; d
++)
1364 mpz_clear (delta
[d
]);
1365 mpz_clear (start
[d
]);
1368 mpz_clear (stride
[d
]);
1370 gfc_free_constructor (base
);
1374 /* Pull a substring out of an expression. */
1377 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1384 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1385 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1388 *newp
= gfc_copy_expr (p
);
1389 gfc_free ((*newp
)->value
.character
.string
);
1391 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1392 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1393 length
= end
- start
+ 1;
1395 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1396 (*newp
)->value
.character
.length
= length
;
1397 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1398 length
* sizeof (gfc_char_t
));
1405 /* Simplify a subobject reference of a constructor. This occurs when
1406 parameter variable values are substituted. */
1409 simplify_const_ref (gfc_expr
*p
)
1411 gfc_constructor
*cons
;
1416 switch (p
->ref
->type
)
1419 switch (p
->ref
->u
.ar
.type
)
1422 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1429 remove_subobject_ref (p
, cons
);
1433 if (find_array_section (p
, p
->ref
) == FAILURE
)
1435 p
->ref
->u
.ar
.type
= AR_FULL
;
1440 if (p
->ref
->next
!= NULL
1441 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1443 cons
= p
->value
.constructor
;
1444 for (; cons
; cons
= cons
->next
)
1446 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1447 simplify_const_ref (cons
->expr
);
1450 gfc_free_ref_list (p
->ref
);
1461 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1462 remove_subobject_ref (p
, cons
);
1466 if (find_substring_ref (p
, &newp
) == FAILURE
)
1469 gfc_replace_expr (p
, newp
);
1470 gfc_free_ref_list (p
->ref
);
1480 /* Simplify a chain of references. */
1483 simplify_ref_chain (gfc_ref
*ref
, int type
)
1487 for (; ref
; ref
= ref
->next
)
1492 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1494 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1496 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1498 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1504 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1506 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1518 /* Try to substitute the value of a parameter variable. */
1521 simplify_parameter_variable (gfc_expr
*p
, int type
)
1526 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1532 /* Do not copy subobject refs for constant. */
1533 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1534 e
->ref
= copy_ref (p
->ref
);
1535 t
= gfc_simplify_expr (e
, type
);
1537 /* Only use the simplification if it eliminated all subobject references. */
1538 if (t
== SUCCESS
&& !e
->ref
)
1539 gfc_replace_expr (p
, e
);
1546 /* Given an expression, simplify it by collapsing constant
1547 expressions. Most simplification takes place when the expression
1548 tree is being constructed. If an intrinsic function is simplified
1549 at some point, we get called again to collapse the result against
1552 We work by recursively simplifying expression nodes, simplifying
1553 intrinsic functions where possible, which can lead to further
1554 constant collapsing. If an operator has constant operand(s), we
1555 rip the expression apart, and rebuild it, hoping that it becomes
1558 The expression type is defined for:
1559 0 Basic expression parsing
1560 1 Simplifying array constructors -- will substitute
1562 Returns FAILURE on error, SUCCESS otherwise.
1563 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1566 gfc_simplify_expr (gfc_expr
*p
, int type
)
1568 gfc_actual_arglist
*ap
;
1573 switch (p
->expr_type
)
1580 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1581 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1584 if (p
->value
.function
.isym
!= NULL
1585 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1590 case EXPR_SUBSTRING
:
1591 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1594 if (gfc_is_constant_expr (p
))
1599 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1601 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1602 start
--; /* Convert from one-based to zero-based. */
1607 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1608 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1610 end
= p
->value
.character
.length
;
1612 s
= gfc_get_wide_string (end
- start
+ 2);
1613 memcpy (s
, p
->value
.character
.string
+ start
,
1614 (end
- start
) * sizeof (gfc_char_t
));
1615 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1616 gfc_free (p
->value
.character
.string
);
1617 p
->value
.character
.string
= s
;
1618 p
->value
.character
.length
= end
- start
;
1619 p
->ts
.cl
= gfc_get_charlen ();
1620 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1621 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1622 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1623 gfc_free_ref_list (p
->ref
);
1625 p
->expr_type
= EXPR_CONSTANT
;
1630 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1635 /* Only substitute array parameter variables if we are in an
1636 initialization expression, or we want a subsection. */
1637 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1638 && (gfc_init_expr
|| p
->ref
1639 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1641 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1648 gfc_simplify_iterator_var (p
);
1651 /* Simplify subcomponent references. */
1652 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1657 case EXPR_STRUCTURE
:
1659 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1662 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1665 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1666 && p
->ref
->u
.ar
.type
== AR_FULL
)
1667 gfc_expand_constructor (p
);
1669 if (simplify_const_ref (p
) == FAILURE
)
1679 /* Returns the type of an expression with the exception that iterator
1680 variables are automatically integers no matter what else they may
1686 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1693 /* Check an intrinsic arithmetic operation to see if it is consistent
1694 with some type of expression. */
1696 static try check_init_expr (gfc_expr
*);
1699 /* Scalarize an expression for an elemental intrinsic call. */
1702 scalarize_intrinsic_call (gfc_expr
*e
)
1704 gfc_actual_arglist
*a
, *b
;
1705 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1706 gfc_expr
*expr
, *old
;
1707 int n
, i
, rank
[5], array_arg
;
1709 /* Find which, if any, arguments are arrays. Assume that the old
1710 expression carries the type information and that the first arg
1711 that is an array expression carries all the shape information.*/
1713 a
= e
->value
.function
.actual
;
1714 for (; a
; a
= a
->next
)
1717 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1720 expr
= gfc_copy_expr (a
->expr
);
1727 old
= gfc_copy_expr (e
);
1729 gfc_free_constructor (expr
->value
.constructor
);
1730 expr
->value
.constructor
= NULL
;
1733 expr
->where
= old
->where
;
1734 expr
->expr_type
= EXPR_ARRAY
;
1736 /* Copy the array argument constructors into an array, with nulls
1739 a
= old
->value
.function
.actual
;
1740 for (; a
; a
= a
->next
)
1742 /* Check that this is OK for an initialization expression. */
1743 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1747 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1749 rank
[n
] = a
->expr
->rank
;
1750 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1751 args
[n
] = gfc_copy_constructor (ctor
);
1753 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1756 rank
[n
] = a
->expr
->rank
;
1759 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1767 /* Using the array argument as the master, step through the array
1768 calling the function for each element and advancing the array
1769 constructors together. */
1770 ctor
= args
[array_arg
- 1];
1772 for (; ctor
; ctor
= ctor
->next
)
1774 if (expr
->value
.constructor
== NULL
)
1775 expr
->value
.constructor
1776 = new_ctor
= gfc_get_constructor ();
1779 new_ctor
->next
= gfc_get_constructor ();
1780 new_ctor
= new_ctor
->next
;
1782 new_ctor
->expr
= gfc_copy_expr (old
);
1783 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1785 b
= old
->value
.function
.actual
;
1786 for (i
= 0; i
< n
; i
++)
1789 new_ctor
->expr
->value
.function
.actual
1790 = a
= gfc_get_actual_arglist ();
1793 a
->next
= gfc_get_actual_arglist ();
1797 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1799 a
->expr
= gfc_copy_expr (b
->expr
);
1804 /* Simplify the function calls. If the simplification fails, the
1805 error will be flagged up down-stream or the library will deal
1807 gfc_simplify_expr (new_ctor
->expr
, 0);
1809 for (i
= 0; i
< n
; i
++)
1811 args
[i
] = args
[i
]->next
;
1813 for (i
= 1; i
< n
; i
++)
1814 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
1815 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
1821 gfc_free_expr (old
);
1825 gfc_error_now ("elemental function arguments at %C are not compliant");
1828 gfc_free_expr (expr
);
1829 gfc_free_expr (old
);
1835 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1837 gfc_expr
*op1
= e
->value
.op
.op1
;
1838 gfc_expr
*op2
= e
->value
.op
.op2
;
1840 if ((*check_function
) (op1
) == FAILURE
)
1843 switch (e
->value
.op
.operator)
1845 case INTRINSIC_UPLUS
:
1846 case INTRINSIC_UMINUS
:
1847 if (!numeric_type (et0 (op1
)))
1852 case INTRINSIC_EQ_OS
:
1854 case INTRINSIC_NE_OS
:
1856 case INTRINSIC_GT_OS
:
1858 case INTRINSIC_GE_OS
:
1860 case INTRINSIC_LT_OS
:
1862 case INTRINSIC_LE_OS
:
1863 if ((*check_function
) (op2
) == FAILURE
)
1866 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1867 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1869 gfc_error ("Numeric or CHARACTER operands are required in "
1870 "expression at %L", &e
->where
);
1875 case INTRINSIC_PLUS
:
1876 case INTRINSIC_MINUS
:
1877 case INTRINSIC_TIMES
:
1878 case INTRINSIC_DIVIDE
:
1879 case INTRINSIC_POWER
:
1880 if ((*check_function
) (op2
) == FAILURE
)
1883 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1886 if (e
->value
.op
.operator == INTRINSIC_POWER
1887 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1889 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1890 "exponent in an initialization "
1891 "expression at %L", &op2
->where
)
1898 case INTRINSIC_CONCAT
:
1899 if ((*check_function
) (op2
) == FAILURE
)
1902 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1904 gfc_error ("Concatenation operator in expression at %L "
1905 "must have two CHARACTER operands", &op1
->where
);
1909 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1911 gfc_error ("Concat operator at %L must concatenate strings of the "
1912 "same kind", &e
->where
);
1919 if (et0 (op1
) != BT_LOGICAL
)
1921 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1922 "operand", &op1
->where
);
1931 case INTRINSIC_NEQV
:
1932 if ((*check_function
) (op2
) == FAILURE
)
1935 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1937 gfc_error ("LOGICAL operands are required in expression at %L",
1944 case INTRINSIC_PARENTHESES
:
1948 gfc_error ("Only intrinsic operators can be used in expression at %L",
1956 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1963 check_init_expr_arguments (gfc_expr
*e
)
1965 gfc_actual_arglist
*ap
;
1967 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1968 if (check_init_expr (ap
->expr
) == FAILURE
)
1974 /* F95, 7.1.6.1, Initialization expressions, (7)
1975 F2003, 7.1.7 Initialization expression, (8) */
1978 check_inquiry (gfc_expr
*e
, int not_restricted
)
1981 const char *const *functions
;
1983 static const char *const inquiry_func_f95
[] = {
1984 "lbound", "shape", "size", "ubound",
1985 "bit_size", "len", "kind",
1986 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1987 "precision", "radix", "range", "tiny",
1991 static const char *const inquiry_func_f2003
[] = {
1992 "lbound", "shape", "size", "ubound",
1993 "bit_size", "len", "kind",
1994 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1995 "precision", "radix", "range", "tiny",
2000 gfc_actual_arglist
*ap
;
2002 if (!e
->value
.function
.isym
2003 || !e
->value
.function
.isym
->inquiry
)
2006 /* An undeclared parameter will get us here (PR25018). */
2007 if (e
->symtree
== NULL
)
2010 name
= e
->symtree
->n
.sym
->name
;
2012 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2013 ? inquiry_func_f2003
: inquiry_func_f95
;
2015 for (i
= 0; functions
[i
]; i
++)
2016 if (strcmp (functions
[i
], name
) == 0)
2019 if (functions
[i
] == NULL
)
2022 /* At this point we have an inquiry function with a variable argument. The
2023 type of the variable might be undefined, but we need it now, because the
2024 arguments of these functions are not allowed to be undefined. */
2026 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2031 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2033 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2034 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2038 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2041 /* Assumed character length will not reduce to a constant expression
2042 with LEN, as required by the standard. */
2043 if (i
== 5 && not_restricted
2044 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2045 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2047 gfc_error ("Assumed character length variable '%s' in constant "
2048 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2051 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2059 /* F95, 7.1.6.1, Initialization expressions, (5)
2060 F2003, 7.1.7 Initialization expression, (5) */
2063 check_transformational (gfc_expr
*e
)
2065 static const char * const trans_func_f95
[] = {
2066 "repeat", "reshape", "selected_int_kind",
2067 "selected_real_kind", "transfer", "trim", NULL
2073 if (!e
->value
.function
.isym
2074 || !e
->value
.function
.isym
->transformational
)
2077 name
= e
->symtree
->n
.sym
->name
;
2079 /* NULL() is dealt with below. */
2080 if (strcmp ("null", name
) == 0)
2083 for (i
= 0; trans_func_f95
[i
]; i
++)
2084 if (strcmp (trans_func_f95
[i
], name
) == 0)
2087 /* FIXME, F2003: implement translation of initialization
2088 expressions before enabling this check. For F95, error
2089 out if the transformational function is not in the list. */
2091 if (trans_func_f95
[i
] == NULL
2092 && gfc_notify_std (GFC_STD_F2003
,
2093 "transformational intrinsic '%s' at %L is not permitted "
2094 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2097 if (trans_func_f95
[i
] == NULL
)
2099 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2100 "in an initialization expression", name
, &e
->where
);
2105 return check_init_expr_arguments (e
);
2109 /* F95, 7.1.6.1, Initialization expressions, (6)
2110 F2003, 7.1.7 Initialization expression, (6) */
2113 check_null (gfc_expr
*e
)
2115 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2118 return check_init_expr_arguments (e
);
2123 check_elemental (gfc_expr
*e
)
2125 if (!e
->value
.function
.isym
2126 || !e
->value
.function
.isym
->elemental
)
2129 if (e
->ts
.type
!= BT_INTEGER
2130 && e
->ts
.type
!= BT_CHARACTER
2131 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2132 "nonstandard initialization expression at %L",
2133 &e
->where
) == FAILURE
)
2136 return check_init_expr_arguments (e
);
2141 check_conversion (gfc_expr
*e
)
2143 if (!e
->value
.function
.isym
2144 || !e
->value
.function
.isym
->conversion
)
2147 return check_init_expr_arguments (e
);
2151 /* Verify that an expression is an initialization expression. A side
2152 effect is that the expression tree is reduced to a single constant
2153 node if all goes well. This would normally happen when the
2154 expression is constructed but function references are assumed to be
2155 intrinsics in the context of initialization expressions. If
2156 FAILURE is returned an error message has been generated. */
2159 check_init_expr (gfc_expr
*e
)
2163 gfc_intrinsic_sym
*isym
;
2168 switch (e
->expr_type
)
2171 t
= check_intrinsic_op (e
, check_init_expr
);
2173 t
= gfc_simplify_expr (e
, 0);
2180 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2182 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2184 gfc_error ("Function '%s' in initialization expression at %L "
2185 "must be an intrinsic or a specification function",
2186 e
->symtree
->n
.sym
->name
, &e
->where
);
2190 if ((m
= check_conversion (e
)) == MATCH_NO
2191 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2192 && (m
= check_null (e
)) == MATCH_NO
2193 && (m
= check_transformational (e
)) == MATCH_NO
2194 && (m
= check_elemental (e
)) == MATCH_NO
)
2196 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2197 "in an initialization expression",
2198 e
->symtree
->n
.sym
->name
, &e
->where
);
2202 /* Try to scalarize an elemental intrinsic function that has an
2204 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2205 if (isym
&& isym
->elemental
2206 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2211 t
= gfc_simplify_expr (e
, 0);
2218 if (gfc_check_iter_variable (e
) == SUCCESS
)
2221 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2223 /* A PARAMETER shall not be used to define itself, i.e.
2224 REAL, PARAMETER :: x = transfer(0, x)
2226 if (!e
->symtree
->n
.sym
->value
)
2228 gfc_error("PARAMETER '%s' is used at %L before its definition "
2229 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2233 t
= simplify_parameter_variable (e
, 0);
2238 if (gfc_in_match_data ())
2243 if (e
->symtree
->n
.sym
->as
)
2245 switch (e
->symtree
->n
.sym
->as
->type
)
2247 case AS_ASSUMED_SIZE
:
2248 gfc_error ("Assumed size array '%s' at %L is not permitted "
2249 "in an initialization expression",
2250 e
->symtree
->n
.sym
->name
, &e
->where
);
2253 case AS_ASSUMED_SHAPE
:
2254 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2255 "in an initialization expression",
2256 e
->symtree
->n
.sym
->name
, &e
->where
);
2260 gfc_error ("Deferred array '%s' at %L is not permitted "
2261 "in an initialization expression",
2262 e
->symtree
->n
.sym
->name
, &e
->where
);
2266 gfc_error ("Array '%s' at %L is a variable, which does "
2267 "not reduce to a constant expression",
2268 e
->symtree
->n
.sym
->name
, &e
->where
);
2276 gfc_error ("Parameter '%s' at %L has not been declared or is "
2277 "a variable, which does not reduce to a constant "
2278 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2287 case EXPR_SUBSTRING
:
2288 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2292 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2294 t
= gfc_simplify_expr (e
, 0);
2298 case EXPR_STRUCTURE
:
2302 t
= gfc_check_constructor (e
, check_init_expr
);
2306 t
= gfc_check_constructor (e
, check_init_expr
);
2310 t
= gfc_expand_constructor (e
);
2314 t
= gfc_check_constructor_type (e
);
2318 gfc_internal_error ("check_init_expr(): Unknown expression type");
2325 /* Match an initialization expression. We work by first matching an
2326 expression, then reducing it to a constant. */
2329 gfc_match_init_expr (gfc_expr
**result
)
2335 m
= gfc_match_expr (&expr
);
2340 t
= gfc_resolve_expr (expr
);
2342 t
= check_init_expr (expr
);
2347 gfc_free_expr (expr
);
2351 if (expr
->expr_type
== EXPR_ARRAY
2352 && (gfc_check_constructor_type (expr
) == FAILURE
2353 || gfc_expand_constructor (expr
) == FAILURE
))
2355 gfc_free_expr (expr
);
2359 /* Not all inquiry functions are simplified to constant expressions
2360 so it is necessary to call check_inquiry again. */
2361 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2362 && !gfc_in_match_data ())
2364 gfc_error ("Initialization expression didn't reduce %C");
2374 static try check_restricted (gfc_expr
*);
2376 /* Given an actual argument list, test to see that each argument is a
2377 restricted expression and optionally if the expression type is
2378 integer or character. */
2381 restricted_args (gfc_actual_arglist
*a
)
2383 for (; a
; a
= a
->next
)
2385 if (check_restricted (a
->expr
) == FAILURE
)
2393 /************* Restricted/specification expressions *************/
2396 /* Make sure a non-intrinsic function is a specification function. */
2399 external_spec_function (gfc_expr
*e
)
2403 f
= e
->value
.function
.esym
;
2405 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2407 gfc_error ("Specification function '%s' at %L cannot be a statement "
2408 "function", f
->name
, &e
->where
);
2412 if (f
->attr
.proc
== PROC_INTERNAL
)
2414 gfc_error ("Specification function '%s' at %L cannot be an internal "
2415 "function", f
->name
, &e
->where
);
2419 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2421 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2426 if (f
->attr
.recursive
)
2428 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2429 f
->name
, &e
->where
);
2433 return restricted_args (e
->value
.function
.actual
);
2437 /* Check to see that a function reference to an intrinsic is a
2438 restricted expression. */
2441 restricted_intrinsic (gfc_expr
*e
)
2443 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2444 if (check_inquiry (e
, 0) == MATCH_YES
)
2447 return restricted_args (e
->value
.function
.actual
);
2451 /* Verify that an expression is a restricted expression. Like its
2452 cousin check_init_expr(), an error message is generated if we
2456 check_restricted (gfc_expr
*e
)
2464 switch (e
->expr_type
)
2467 t
= check_intrinsic_op (e
, check_restricted
);
2469 t
= gfc_simplify_expr (e
, 0);
2474 t
= e
->value
.function
.esym
? external_spec_function (e
)
2475 : restricted_intrinsic (e
);
2479 sym
= e
->symtree
->n
.sym
;
2482 /* If a dummy argument appears in a context that is valid for a
2483 restricted expression in an elemental procedure, it will have
2484 already been simplified away once we get here. Therefore we
2485 don't need to jump through hoops to distinguish valid from
2487 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2488 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2490 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2491 sym
->name
, &e
->where
);
2495 if (sym
->attr
.optional
)
2497 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2498 sym
->name
, &e
->where
);
2502 if (sym
->attr
.intent
== INTENT_OUT
)
2504 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2505 sym
->name
, &e
->where
);
2509 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2510 processed in resolve.c(resolve_formal_arglist). This is done so
2511 that host associated dummy array indices are accepted (PR23446).
2512 This mechanism also does the same for the specification expressions
2513 of array-valued functions. */
2514 if (sym
->attr
.in_common
2515 || sym
->attr
.use_assoc
2517 || sym
->attr
.implied_index
2518 || sym
->ns
!= gfc_current_ns
2519 || (sym
->ns
->proc_name
!= NULL
2520 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2521 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2527 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2528 sym
->name
, &e
->where
);
2537 case EXPR_SUBSTRING
:
2538 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2542 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2544 t
= gfc_simplify_expr (e
, 0);
2548 case EXPR_STRUCTURE
:
2549 t
= gfc_check_constructor (e
, check_restricted
);
2553 t
= gfc_check_constructor (e
, check_restricted
);
2557 gfc_internal_error ("check_restricted(): Unknown expression type");
2564 /* Check to see that an expression is a specification expression. If
2565 we return FAILURE, an error has been generated. */
2568 gfc_specification_expr (gfc_expr
*e
)
2574 if (e
->ts
.type
!= BT_INTEGER
)
2576 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2577 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2581 if (e
->expr_type
== EXPR_FUNCTION
2582 && !e
->value
.function
.isym
2583 && !e
->value
.function
.esym
2584 && !gfc_pure (e
->symtree
->n
.sym
))
2586 gfc_error ("Function '%s' at %L must be PURE",
2587 e
->symtree
->n
.sym
->name
, &e
->where
);
2588 /* Prevent repeat error messages. */
2589 e
->symtree
->n
.sym
->attr
.pure
= 1;
2595 gfc_error ("Expression at %L must be scalar", &e
->where
);
2599 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2602 return check_restricted (e
);
2606 /************** Expression conformance checks. *************/
2608 /* Given two expressions, make sure that the arrays are conformable. */
2611 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2613 int op1_flag
, op2_flag
, d
;
2614 mpz_t op1_size
, op2_size
;
2617 if (op1
->rank
== 0 || op2
->rank
== 0)
2620 if (op1
->rank
!= op2
->rank
)
2622 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2623 op1
->rank
, op2
->rank
, &op1
->where
);
2629 for (d
= 0; d
< op1
->rank
; d
++)
2631 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2632 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2634 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2636 gfc_error ("Different shape for %s at %L on dimension %d "
2637 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2638 (int) mpz_get_si (op1_size
),
2639 (int) mpz_get_si (op2_size
));
2645 mpz_clear (op1_size
);
2647 mpz_clear (op2_size
);
2657 /* Given an assignable expression and an arbitrary expression, make
2658 sure that the assignment can take place. */
2661 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2667 sym
= lvalue
->symtree
->n
.sym
;
2669 /* Check INTENT(IN), unless the object itself is the component or
2670 sub-component of a pointer. */
2671 has_pointer
= sym
->attr
.pointer
;
2673 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2674 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2680 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2682 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2683 sym
->name
, &lvalue
->where
);
2687 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2688 variable local to a function subprogram. Its existence begins when
2689 execution of the function is initiated and ends when execution of the
2690 function is terminated...
2691 Therefore, the left hand side is no longer a variable, when it is: */
2692 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2693 && !sym
->attr
.external
)
2698 /* (i) Use associated; */
2699 if (sym
->attr
.use_assoc
)
2702 /* (ii) The assignment is in the main program; or */
2703 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2706 /* (iii) A module or internal procedure... */
2707 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2708 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2709 && gfc_current_ns
->parent
2710 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2711 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2712 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2714 /* ... that is not a function... */
2715 if (!gfc_current_ns
->proc_name
->attr
.function
)
2718 /* ... or is not an entry and has a different name. */
2719 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2723 /* (iv) Host associated and not the function symbol or the
2724 parent result. This picks up sibling references, which
2725 cannot be entries. */
2726 if (!sym
->attr
.entry
2727 && sym
->ns
== gfc_current_ns
->parent
2728 && sym
!= gfc_current_ns
->proc_name
2729 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2734 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2739 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2741 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2742 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2746 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2748 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2753 if (rvalue
->expr_type
== EXPR_NULL
)
2755 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2756 && lvalue
->symtree
->n
.sym
->attr
.data
)
2760 gfc_error ("NULL appears on right-hand side in assignment at %L",
2766 if (sym
->attr
.cray_pointee
2767 && lvalue
->ref
!= NULL
2768 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2769 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2771 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2772 "is illegal", &lvalue
->where
);
2776 /* This is possibly a typo: x = f() instead of x => f(). */
2777 if (gfc_option
.warn_surprising
2778 && rvalue
->expr_type
== EXPR_FUNCTION
2779 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2780 gfc_warning ("POINTER valued function appears on right-hand side of "
2781 "assignment at %L", &rvalue
->where
);
2783 /* Check size of array assignments. */
2784 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2785 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2788 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2789 && lvalue
->symtree
->n
.sym
->attr
.data
2790 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2791 "initialize non-integer variable '%s'",
2792 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2795 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2796 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2797 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2798 &rvalue
->where
) == FAILURE
)
2801 /* Handle the case of a BOZ literal on the RHS. */
2802 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2805 if (gfc_option
.warn_surprising
)
2806 gfc_warning ("BOZ literal at %L is bitwise transferred "
2807 "non-integer symbol '%s'", &rvalue
->where
,
2808 lvalue
->symtree
->n
.sym
->name
);
2809 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2811 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2813 if (rc
== ARITH_UNDERFLOW
)
2814 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2815 ". This check can be disabled with the option "
2816 "-fno-range-check", &rvalue
->where
);
2817 else if (rc
== ARITH_OVERFLOW
)
2818 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2819 ". This check can be disabled with the option "
2820 "-fno-range-check", &rvalue
->where
);
2821 else if (rc
== ARITH_NAN
)
2822 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2823 ". This check can be disabled with the option "
2824 "-fno-range-check", &rvalue
->where
);
2829 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2834 /* Numeric can be converted to any other numeric. And Hollerith can be
2835 converted to any other type. */
2836 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2837 || rvalue
->ts
.type
== BT_HOLLERITH
)
2840 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2843 gfc_error ("Incompatible types in assignment at %L; attempted assignment "
2844 "of %s to %s", &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2845 gfc_typename (&lvalue
->ts
));
2850 /* Assignment is the only case where character variables of different
2851 kind values can be converted into one another. */
2852 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
2854 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2855 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
2860 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2864 /* Check that a pointer assignment is OK. We first check lvalue, and
2865 we only check rvalue if it's not an assignment to NULL() or a
2866 NULLIFY statement. */
2869 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2871 symbol_attribute attr
;
2874 int pointer
, check_intent_in
;
2876 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2878 gfc_error ("Pointer assignment target is not a POINTER at %L",
2883 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2884 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2886 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2887 "l-value since it is a procedure",
2888 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2893 /* Check INTENT(IN), unless the object itself is the component or
2894 sub-component of a pointer. */
2895 check_intent_in
= 1;
2896 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2898 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2901 check_intent_in
= 0;
2903 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2907 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2909 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2910 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2916 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2920 is_pure
= gfc_pure (NULL
);
2922 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2923 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2925 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2929 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2930 kind, etc for lvalue and rvalue must match, and rvalue must be a
2931 pure variable if we're in a pure function. */
2932 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2935 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2937 gfc_error ("Different types in pointer assignment at %L; attempted "
2938 "assignment of %s to %s", &lvalue
->where
,
2939 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
2943 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2945 gfc_error ("Different kind type parameters in pointer "
2946 "assignment at %L", &lvalue
->where
);
2950 if (lvalue
->rank
!= rvalue
->rank
)
2952 gfc_error ("Different ranks in pointer assignment at %L",
2957 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2958 if (rvalue
->expr_type
== EXPR_NULL
)
2961 if (lvalue
->ts
.type
== BT_CHARACTER
2962 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2963 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2964 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2965 rvalue
->ts
.cl
->length
)) == 1)
2967 gfc_error ("Different character lengths in pointer "
2968 "assignment at %L", &lvalue
->where
);
2972 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2973 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2975 attr
= gfc_expr_attr (rvalue
);
2976 if (!attr
.target
&& !attr
.pointer
)
2978 gfc_error ("Pointer assignment target is neither TARGET "
2979 "nor POINTER at %L", &rvalue
->where
);
2983 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2985 gfc_error ("Bad target in pointer assignment in PURE "
2986 "procedure at %L", &rvalue
->where
);
2989 if (gfc_has_vector_index (rvalue
))
2991 gfc_error ("Pointer assignment with vector subscript "
2992 "on rhs at %L", &rvalue
->where
);
2996 if (attr
.protected && attr
.use_assoc
)
2998 gfc_error ("Pointer assigment target has PROTECTED "
2999 "attribute at %L", &rvalue
->where
);
3007 /* Relative of gfc_check_assign() except that the lvalue is a single
3008 symbol. Used for initialization assignments. */
3011 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3016 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3018 lvalue
.expr_type
= EXPR_VARIABLE
;
3019 lvalue
.ts
= sym
->ts
;
3021 lvalue
.rank
= sym
->as
->rank
;
3022 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3023 lvalue
.symtree
->n
.sym
= sym
;
3024 lvalue
.where
= sym
->declared_at
;
3026 if (sym
->attr
.pointer
)
3027 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3029 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3031 gfc_free (lvalue
.symtree
);
3037 /* Get an expression for a default initializer. */
3040 gfc_default_initializer (gfc_typespec
*ts
)
3042 gfc_constructor
*tail
;
3046 /* See if we have a default initializer. */
3047 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3048 if (c
->initializer
|| c
->allocatable
)
3054 /* Build the constructor. */
3055 init
= gfc_get_expr ();
3056 init
->expr_type
= EXPR_STRUCTURE
;
3058 init
->where
= ts
->derived
->declared_at
;
3061 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3064 init
->value
.constructor
= tail
= gfc_get_constructor ();
3067 tail
->next
= gfc_get_constructor ();
3072 tail
->expr
= gfc_copy_expr (c
->initializer
);
3076 tail
->expr
= gfc_get_expr ();
3077 tail
->expr
->expr_type
= EXPR_NULL
;
3078 tail
->expr
->ts
= c
->ts
;
3085 /* Given a symbol, create an expression node with that symbol as a
3086 variable. If the symbol is array valued, setup a reference of the
3090 gfc_get_variable_expr (gfc_symtree
*var
)
3094 e
= gfc_get_expr ();
3095 e
->expr_type
= EXPR_VARIABLE
;
3097 e
->ts
= var
->n
.sym
->ts
;
3099 if (var
->n
.sym
->as
!= NULL
)
3101 e
->rank
= var
->n
.sym
->as
->rank
;
3102 e
->ref
= gfc_get_ref ();
3103 e
->ref
->type
= REF_ARRAY
;
3104 e
->ref
->u
.ar
.type
= AR_FULL
;
3111 /* General expression traversal function. */
3114 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3115 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3120 gfc_actual_arglist
*args
;
3127 if ((*func
) (expr
, sym
, &f
))
3130 if (expr
->ts
.type
== BT_CHARACTER
3132 && expr
->ts
.cl
->length
3133 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3134 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3137 switch (expr
->expr_type
)
3140 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3142 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3150 case EXPR_SUBSTRING
:
3153 case EXPR_STRUCTURE
:
3155 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3157 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3161 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3163 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3165 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3167 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3174 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3176 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3192 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3194 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3196 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3198 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3204 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3206 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3211 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3212 && ref
->u
.c
.component
->ts
.cl
3213 && ref
->u
.c
.component
->ts
.cl
->length
3214 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3216 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3220 if (ref
->u
.c
.component
->as
)
3221 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3223 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3226 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3240 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3243 expr_set_symbols_referenced (gfc_expr
*expr
,
3244 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3245 int *f ATTRIBUTE_UNUSED
)
3247 if (expr
->expr_type
!= EXPR_VARIABLE
)
3249 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3254 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3256 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);