?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config/rs6000/rs6000.md (popcount<mode>2): Rewrite.
[official-gcc.git] / gcc / fortran / expr.c
blobdbe51888656bf1549aada81e4b58a4bfb3984d15
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
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
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
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA. */
22
23 #include "config.h"
24 #include "system.h"
25 #include "gfortran.h"
26 #include "arith.h"
27 #include "match.h"
28
29 /* Get a new expr node. */
30
31 gfc_expr *
32 gfc_get_expr (void)
33 {
34 gfc_expr *e;
35
36 e = gfc_getmem (sizeof (gfc_expr));
37 gfc_clear_ts (&e->ts);
38 e->shape = NULL;
39 e->ref = NULL;
40 e->symtree = NULL;
41 e->con_by_offset = NULL;
42 return e;
43 }
44
45
46 /* Free an argument list and everything below it. */
47
48 void
49 gfc_free_actual_arglist (gfc_actual_arglist *a1)
50 {
51 gfc_actual_arglist *a2;
52
53 while (a1)
54 {
55 a2 = a1->next;
56 gfc_free_expr (a1->expr);
57 gfc_free (a1);
58 a1 = a2;
59 }
60 }
61
62
63 /* Copy an arglist structure and all of the arguments. */
64
65 gfc_actual_arglist *
66 gfc_copy_actual_arglist (gfc_actual_arglist *p)
67 {
68 gfc_actual_arglist *head, *tail, *new;
69
70 head = tail = NULL;
71
72 for (; p; p = p->next)
73 {
74 new = gfc_get_actual_arglist ();
75 *new = *p;
76
77 new->expr = gfc_copy_expr (p->expr);
78 new->next = NULL;
79
80 if (head == NULL)
81 head = new;
82 else
83 tail->next = new;
84
85 tail = new;
86 }
87
88 return head;
89 }
90
91
92 /* Free a list of reference structures. */
93
94 void
95 gfc_free_ref_list (gfc_ref *p)
96 {
97 gfc_ref *q;
98 int i;
99
100 for (; p; p = q)
101 {
102 q = p->next;
103
104 switch (p->type)
105 {
106 case REF_ARRAY:
107 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
108 {
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]);
112 }
113
114 break;
115
116 case REF_SUBSTRING:
117 gfc_free_expr (p->u.ss.start);
118 gfc_free_expr (p->u.ss.end);
119 break;
120
121 case REF_COMPONENT:
122 break;
123 }
124
125 gfc_free (p);
126 }
127 }
128
129
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. */
134
135 static void
136 free_expr0 (gfc_expr *e)
137 {
138 int n;
139
140 switch (e->expr_type)
141 {
142 case EXPR_CONSTANT:
143 if (e->from_H)
144 {
145 gfc_free (e->value.character.string);
146 break;
147 }
148
149 switch (e->ts.type)
150 {
151 case BT_INTEGER:
152 mpz_clear (e->value.integer);
153 break;
154
155 case BT_REAL:
156 mpfr_clear (e->value.real);
157 break;
158
159 case BT_CHARACTER:
160 case BT_HOLLERITH:
161 gfc_free (e->value.character.string);
162 break;
163
164 case BT_COMPLEX:
165 mpfr_clear (e->value.complex.r);
166 mpfr_clear (e->value.complex.i);
167 break;
168
169 default:
170 break;
171 }
172
173 break;
174
175 case EXPR_OP:
176 if (e->value.op.op1 != NULL)
177 gfc_free_expr (e->value.op.op1);
178 if (e->value.op.op2 != NULL)
179 gfc_free_expr (e->value.op.op2);
180 break;
181
182 case EXPR_FUNCTION:
183 gfc_free_actual_arglist (e->value.function.actual);
184 break;
185
186 case EXPR_VARIABLE:
187 break;
188
189 case EXPR_ARRAY:
190 case EXPR_STRUCTURE:
191 gfc_free_constructor (e->value.constructor);
192 break;
193
194 case EXPR_SUBSTRING:
195 gfc_free (e->value.character.string);
196 break;
197
198 case EXPR_NULL:
199 break;
200
201 default:
202 gfc_internal_error ("free_expr0(): Bad expr type");
203 }
204
205 /* Free a shape array. */
206 if (e->shape != NULL)
207 {
208 for (n = 0; n < e->rank; n++)
209 mpz_clear (e->shape[n]);
210
211 gfc_free (e->shape);
212 }
213
214 gfc_free_ref_list (e->ref);
215
216 memset (e, '\0', sizeof (gfc_expr));
217 }
218
219
220 /* Free an expression node and everything beneath it. */
221
222 void
223 gfc_free_expr (gfc_expr *e)
224 {
225 if (e == NULL)
226 return;
227 if (e->con_by_offset)
228 splay_tree_delete (e->con_by_offset);
229 free_expr0 (e);
230 gfc_free (e);
231 }
232
233
234 /* Graft the *src expression onto the *dest subexpression. */
235
236 void
237 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
238 {
239 free_expr0 (dest);
240 *dest = *src;
241 gfc_free (src);
242 }
243
244
245 /* Try to extract an integer constant from the passed expression node.
246 Returns an error message or NULL if the result is set. It is
247 tempting to generate an error and return SUCCESS or FAILURE, but
248 failure is OK for some callers. */
249
250 const char *
251 gfc_extract_int (gfc_expr *expr, int *result)
252 {
253 if (expr->expr_type != EXPR_CONSTANT)
254 return _("Constant expression required at %C");
255
256 if (expr->ts.type != BT_INTEGER)
257 return _("Integer expression required at %C");
258
259 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
260 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
261 {
262 return _("Integer value too large in expression at %C");
263 }
264
265 *result = (int) mpz_get_si (expr->value.integer);
266
267 return NULL;
268 }
269
270
271 /* Recursively copy a list of reference structures. */
272
273 static gfc_ref *
274 copy_ref (gfc_ref *src)
275 {
276 gfc_array_ref *ar;
277 gfc_ref *dest;
278
279 if (src == NULL)
280 return NULL;
281
282 dest = gfc_get_ref ();
283 dest->type = src->type;
284
285 switch (src->type)
286 {
287 case REF_ARRAY:
288 ar = gfc_copy_array_ref (&src->u.ar);
289 dest->u.ar = *ar;
290 gfc_free (ar);
291 break;
292
293 case REF_COMPONENT:
294 dest->u.c = src->u.c;
295 break;
296
297 case REF_SUBSTRING:
298 dest->u.ss = src->u.ss;
299 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
300 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
301 break;
302 }
303
304 dest->next = copy_ref (src->next);
305
306 return dest;
307 }
308
309
310 /* Detect whether an expression has any vector index array references. */
311
312 int
313 gfc_has_vector_index (gfc_expr *e)
314 {
315 gfc_ref *ref;
316 int i;
317 for (ref = e->ref; ref; ref = ref->next)
318 if (ref->type == REF_ARRAY)
319 for (i = 0; i < ref->u.ar.dimen; i++)
320 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
321 return 1;
322 return 0;
323 }
324
325
326 /* Copy a shape array. */
327
328 mpz_t *
329 gfc_copy_shape (mpz_t *shape, int rank)
330 {
331 mpz_t *new_shape;
332 int n;
333
334 if (shape == NULL)
335 return NULL;
336
337 new_shape = gfc_get_shape (rank);
338
339 for (n = 0; n < rank; n++)
340 mpz_init_set (new_shape[n], shape[n]);
341
342 return new_shape;
343 }
344
345
346 /* Copy a shape array excluding dimension N, where N is an integer
347 constant expression. Dimensions are numbered in fortran style --
348 starting with ONE.
349
350 So, if the original shape array contains R elements
351 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
352 the result contains R-1 elements:
353 { s1 ... sN-1 sN+1 ... sR-1}
354
355 If anything goes wrong -- N is not a constant, its value is out
356 of range -- or anything else, just returns NULL.
357 */
358
359 mpz_t *
360 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
361 {
362 mpz_t *new_shape, *s;
363 int i, n;
364
365 if (shape == NULL
366 || rank <= 1
367 || dim == NULL
368 || dim->expr_type != EXPR_CONSTANT
369 || dim->ts.type != BT_INTEGER)
370 return NULL;
371
372 n = mpz_get_si (dim->value.integer);
373 n--; /* Convert to zero based index */
374 if (n < 0 || n >= rank)
375 return NULL;
376
377 s = new_shape = gfc_get_shape (rank - 1);
378
379 for (i = 0; i < rank; i++)
380 {
381 if (i == n)
382 continue;
383 mpz_init_set (*s, shape[i]);
384 s++;
385 }
386
387 return new_shape;
388 }
389
390
391 /* Given an expression pointer, return a copy of the expression. This
392 subroutine is recursive. */
393
394 gfc_expr *
395 gfc_copy_expr (gfc_expr *p)
396 {
397 gfc_expr *q;
398 char *s;
399
400 if (p == NULL)
401 return NULL;
402
403 q = gfc_get_expr ();
404 *q = *p;
405
406 switch (q->expr_type)
407 {
408 case EXPR_SUBSTRING:
409 s = gfc_getmem (p->value.character.length + 1);
410 q->value.character.string = s;
411
412 memcpy (s, p->value.character.string, p->value.character.length + 1);
413 break;
414
415 case EXPR_CONSTANT:
416 if (p->from_H)
417 {
418 s = gfc_getmem (p->value.character.length + 1);
419 q->value.character.string = s;
420
421 memcpy (s, p->value.character.string, p->value.character.length + 1);
422 break;
423 }
424 switch (q->ts.type)
425 {
426 case BT_INTEGER:
427 mpz_init_set (q->value.integer, p->value.integer);
428 break;
429
430 case BT_REAL:
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);
434 break;
435
436 case BT_COMPLEX:
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);
442 break;
443
444 case BT_CHARACTER:
445 case BT_HOLLERITH:
446 s = gfc_getmem (p->value.character.length + 1);
447 q->value.character.string = s;
448
449 memcpy (s, p->value.character.string, p->value.character.length + 1);
450 break;
451
452 case BT_LOGICAL:
453 case BT_DERIVED:
454 break; /* Already done */
455
456 case BT_PROCEDURE:
457 case BT_UNKNOWN:
458 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
459 /* Not reached */
460 }
461
462 break;
463
464 case EXPR_OP:
465 switch (q->value.op.operator)
466 {
467 case INTRINSIC_NOT:
468 case INTRINSIC_UPLUS:
469 case INTRINSIC_UMINUS:
470 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
471 break;
472
473 default: /* Binary operators */
474 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
475 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
476 break;
477 }
478
479 break;
480
481 case EXPR_FUNCTION:
482 q->value.function.actual =
483 gfc_copy_actual_arglist (p->value.function.actual);
484 break;
485
486 case EXPR_STRUCTURE:
487 case EXPR_ARRAY:
488 q->value.constructor = gfc_copy_constructor (p->value.constructor);
489 break;
490
491 case EXPR_VARIABLE:
492 case EXPR_NULL:
493 break;
494 }
495
496 q->shape = gfc_copy_shape (p->shape, p->rank);
497
498 q->ref = copy_ref (p->ref);
499
500 return q;
501 }
502
503
504 /* Return the maximum kind of two expressions. In general, higher
505 kind numbers mean more precision for numeric types. */
506
507 int
508 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
509 {
510 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
511 }
512
513
514 /* Returns nonzero if the type is numeric, zero otherwise. */
515
516 static int
517 numeric_type (bt type)
518 {
519 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
520 }
521
522
523 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
524
525 int
526 gfc_numeric_ts (gfc_typespec *ts)
527 {
528 return numeric_type (ts->type);
529 }
530
531
532 /* Returns an expression node that is an integer constant. */
533
534 gfc_expr *
535 gfc_int_expr (int i)
536 {
537 gfc_expr *p;
538
539 p = gfc_get_expr ();
540
541 p->expr_type = EXPR_CONSTANT;
542 p->ts.type = BT_INTEGER;
543 p->ts.kind = gfc_default_integer_kind;
544
545 p->where = gfc_current_locus;
546 mpz_init_set_si (p->value.integer, i);
547
548 return p;
549 }
550
551
552 /* Returns an expression node that is a logical constant. */
553
554 gfc_expr *
555 gfc_logical_expr (int i, locus *where)
556 {
557 gfc_expr *p;
558
559 p = gfc_get_expr ();
560
561 p->expr_type = EXPR_CONSTANT;
562 p->ts.type = BT_LOGICAL;
563 p->ts.kind = gfc_default_logical_kind;
564
565 if (where == NULL)
566 where = &gfc_current_locus;
567 p->where = *where;
568 p->value.logical = i;
569
570 return p;
571 }
572
573
574 /* Return an expression node with an optional argument list attached.
575 A variable number of gfc_expr pointers are strung together in an
576 argument list with a NULL pointer terminating the list. */
577
578 gfc_expr *
579 gfc_build_conversion (gfc_expr *e)
580 {
581 gfc_expr *p;
582
583 p = gfc_get_expr ();
584 p->expr_type = EXPR_FUNCTION;
585 p->symtree = NULL;
586 p->value.function.actual = NULL;
587
588 p->value.function.actual = gfc_get_actual_arglist ();
589 p->value.function.actual->expr = e;
590
591 return p;
592 }
593
594
595 /* Given an expression node with some sort of numeric binary
596 expression, insert type conversions required to make the operands
597 have the same type.
598
599 The exception is that the operands of an exponential don't have to
600 have the same type. If possible, the base is promoted to the type
601 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
602 1.0**2 stays as it is. */
603
604 void
605 gfc_type_convert_binary (gfc_expr *e)
606 {
607 gfc_expr *op1, *op2;
608
609 op1 = e->value.op.op1;
610 op2 = e->value.op.op2;
611
612 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
613 {
614 gfc_clear_ts (&e->ts);
615 return;
616 }
617
618 /* Kind conversions of same type. */
619 if (op1->ts.type == op2->ts.type)
620 {
621 if (op1->ts.kind == op2->ts.kind)
622 {
623 /* No type conversions. */
624 e->ts = op1->ts;
625 goto done;
626 }
627
628 if (op1->ts.kind > op2->ts.kind)
629 gfc_convert_type (op2, &op1->ts, 2);
630 else
631 gfc_convert_type (op1, &op2->ts, 2);
632
633 e->ts = op1->ts;
634 goto done;
635 }
636
637 /* Integer combined with real or complex. */
638 if (op2->ts.type == BT_INTEGER)
639 {
640 e->ts = op1->ts;
641
642 /* Special case for ** operator. */
643 if (e->value.op.operator == INTRINSIC_POWER)
644 goto done;
645
646 gfc_convert_type (e->value.op.op2, &e->ts, 2);
647 goto done;
648 }
649
650 if (op1->ts.type == BT_INTEGER)
651 {
652 e->ts = op2->ts;
653 gfc_convert_type (e->value.op.op1, &e->ts, 2);
654 goto done;
655 }
656
657 /* Real combined with complex. */
658 e->ts.type = BT_COMPLEX;
659 if (op1->ts.kind > op2->ts.kind)
660 e->ts.kind = op1->ts.kind;
661 else
662 e->ts.kind = op2->ts.kind;
663 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
664 gfc_convert_type (e->value.op.op1, &e->ts, 2);
665 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
666 gfc_convert_type (e->value.op.op2, &e->ts, 2);
667
668 done:
669 return;
670 }
671
672
673 /* Function to determine if an expression is constant or not. This
674 function expects that the expression has already been simplified. */
675
676 int
677 gfc_is_constant_expr (gfc_expr *e)
678 {
679 gfc_constructor *c;
680 gfc_actual_arglist *arg;
681 int rv;
682
683 if (e == NULL)
684 return 1;
685
686 switch (e->expr_type)
687 {
688 case EXPR_OP:
689 rv = (gfc_is_constant_expr (e->value.op.op1)
690 && (e->value.op.op2 == NULL
691 || gfc_is_constant_expr (e->value.op.op2)));
692
693 break;
694
695 case EXPR_VARIABLE:
696 rv = 0;
697 break;
698
699 case EXPR_FUNCTION:
700 /* Call to intrinsic with at least one argument. */
701 rv = 0;
702 if (e->value.function.isym && e->value.function.actual)
703 {
704 for (arg = e->value.function.actual; arg; arg = arg->next)
705 {
706 if (!gfc_is_constant_expr (arg->expr))
707 break;
708 }
709 if (arg == NULL)
710 rv = 1;
711 }
712 break;
713
714 case EXPR_CONSTANT:
715 case EXPR_NULL:
716 rv = 1;
717 break;
718
719 case EXPR_SUBSTRING:
720 rv = (gfc_is_constant_expr (e->ref->u.ss.start)
721 && gfc_is_constant_expr (e->ref->u.ss.end));
722 break;
723
724 case EXPR_STRUCTURE:
725 rv = 0;
726 for (c = e->value.constructor; c; c = c->next)
727 if (!gfc_is_constant_expr (c->expr))
728 break;
729
730 if (c == NULL)
731 rv = 1;
732 break;
733
734 case EXPR_ARRAY:
735 rv = gfc_constant_ac (e);
736 break;
737
738 default:
739 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
740 }
741
742 return rv;
743 }
744
745
746 /* Try to collapse intrinsic expressions. */
747
748 static try
749 simplify_intrinsic_op (gfc_expr *p, int type)
750 {
751 gfc_expr *op1, *op2, *result;
752
753 if (p->value.op.operator == INTRINSIC_USER)
754 return SUCCESS;
755
756 op1 = p->value.op.op1;
757 op2 = p->value.op.op2;
758
759 if (gfc_simplify_expr (op1, type) == FAILURE)
760 return FAILURE;
761 if (gfc_simplify_expr (op2, type) == FAILURE)
762 return FAILURE;
763
764 if (!gfc_is_constant_expr (op1)
765 || (op2 != NULL && !gfc_is_constant_expr (op2)))
766 return SUCCESS;
767
768 /* Rip p apart */
769 p->value.op.op1 = NULL;
770 p->value.op.op2 = NULL;
771
772 switch (p->value.op.operator)
773 {
774 case INTRINSIC_UPLUS:
775 case INTRINSIC_PARENTHESES:
776 result = gfc_uplus (op1);
777 break;
778
779 case INTRINSIC_UMINUS:
780 result = gfc_uminus (op1);
781 break;
782
783 case INTRINSIC_PLUS:
784 result = gfc_add (op1, op2);
785 break;
786
787 case INTRINSIC_MINUS:
788 result = gfc_subtract (op1, op2);
789 break;
790
791 case INTRINSIC_TIMES:
792 result = gfc_multiply (op1, op2);
793 break;
794
795 case INTRINSIC_DIVIDE:
796 result = gfc_divide (op1, op2);
797 break;
798
799 case INTRINSIC_POWER:
800 result = gfc_power (op1, op2);
801 break;
802
803 case INTRINSIC_CONCAT:
804 result = gfc_concat (op1, op2);
805 break;
806
807 case INTRINSIC_EQ:
808 result = gfc_eq (op1, op2);
809 break;
810
811 case INTRINSIC_NE:
812 result = gfc_ne (op1, op2);
813 break;
814
815 case INTRINSIC_GT:
816 result = gfc_gt (op1, op2);
817 break;
818
819 case INTRINSIC_GE:
820 result = gfc_ge (op1, op2);
821 break;
822
823 case INTRINSIC_LT:
824 result = gfc_lt (op1, op2);
825 break;
826
827 case INTRINSIC_LE:
828 result = gfc_le (op1, op2);
829 break;
830
831 case INTRINSIC_NOT:
832 result = gfc_not (op1);
833 break;
834
835 case INTRINSIC_AND:
836 result = gfc_and (op1, op2);
837 break;
838
839 case INTRINSIC_OR:
840 result = gfc_or (op1, op2);
841 break;
842
843 case INTRINSIC_EQV:
844 result = gfc_eqv (op1, op2);
845 break;
846
847 case INTRINSIC_NEQV:
848 result = gfc_neqv (op1, op2);
849 break;
850
851 default:
852 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
853 }
854
855 if (result == NULL)
856 {
857 gfc_free_expr (op1);
858 gfc_free_expr (op2);
859 return FAILURE;
860 }
861
862 result->rank = p->rank;
863 result->where = p->where;
864 gfc_replace_expr (p, result);
865
866 return SUCCESS;
867 }
868
869
870 /* Subroutine to simplify constructor expressions. Mutually recursive
871 with gfc_simplify_expr(). */
872
873 static try
874 simplify_constructor (gfc_constructor *c, int type)
875 {
876 for (; c; c = c->next)
877 {
878 if (c->iterator
879 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
880 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
881 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
882 return FAILURE;
883
884 if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
885 return FAILURE;
886 }
887
888 return SUCCESS;
889 }
890
891
892 /* Pull a single array element out of an array constructor. */
893
894 static try
895 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
896 gfc_constructor **rval)
897 {
898 unsigned long nelemen;
899 int i;
900 mpz_t delta;
901 mpz_t offset;
902 gfc_expr *e;
903 try t;
904
905 t = SUCCESS;
906 e = NULL;
907
908 mpz_init_set_ui (offset, 0);
909 mpz_init (delta);
910 for (i = 0; i < ar->dimen; i++)
911 {
912 e = gfc_copy_expr (ar->start[i]);
913 if (e->expr_type != EXPR_CONSTANT)
914 {
915 cons = NULL;
916 goto depart;
917 }
918
919 /* Check the bounds. */
920 if (ar->as->upper[i]
921 && (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
922 || mpz_cmp (e->value.integer,
923 ar->as->lower[i]->value.integer) < 0))
924 {
925 gfc_error ("index in dimension %d is out of bounds "
926 "at %L", i + 1, &ar->c_where[i]);
927 cons = NULL;
928 t = FAILURE;
929 goto depart;
930 }
931
932 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
933 mpz_add (offset, offset, delta);
934 }
935
936 if (cons)
937 {
938 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
939 {
940 if (cons->iterator)
941 {
942 cons = NULL;
943 goto depart;
944 }
945 cons = cons->next;
946 }
947 }
948
949 depart:
950 mpz_clear (delta);
951 mpz_clear (offset);
952 if (e)
953 gfc_free_expr (e);
954 *rval = cons;
955 return t;
956 }
957
958
959 /* Find a component of a structure constructor. */
960
961 static gfc_constructor *
962 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
963 {
964 gfc_component *comp;
965 gfc_component *pick;
966
967 comp = ref->u.c.sym->components;
968 pick = ref->u.c.component;
969 while (comp != pick)
970 {
971 comp = comp->next;
972 cons = cons->next;
973 }
974
975 return cons;
976 }
977
978
979 /* Replace an expression with the contents of a constructor, removing
980 the subobject reference in the process. */
981
982 static void
983 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
984 {
985 gfc_expr *e;
986
987 e = cons->expr;
988 cons->expr = NULL;
989 e->ref = p->ref->next;
990 p->ref->next = NULL;
991 gfc_replace_expr (p, e);
992 }
993
994
995 /* Pull an array section out of an array constructor. */
996
997 static try
998 find_array_section (gfc_expr *expr, gfc_ref *ref)
999 {
1000 int idx;
1001 int rank;
1002 int d;
1003 int shape_i;
1004 long unsigned one = 1;
1005 bool incr_ctr;
1006 mpz_t start[GFC_MAX_DIMENSIONS];
1007 mpz_t end[GFC_MAX_DIMENSIONS];
1008 mpz_t stride[GFC_MAX_DIMENSIONS];
1009 mpz_t delta[GFC_MAX_DIMENSIONS];
1010 mpz_t ctr[GFC_MAX_DIMENSIONS];
1011 mpz_t delta_mpz;
1012 mpz_t tmp_mpz;
1013 mpz_t nelts;
1014 mpz_t ptr;
1015 mpz_t index;
1016 gfc_constructor *cons;
1017 gfc_constructor *base;
1018 gfc_expr *begin;
1019 gfc_expr *finish;
1020 gfc_expr *step;
1021 gfc_expr *upper;
1022 gfc_expr *lower;
1023 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1024 try t;
1025
1026 t = SUCCESS;
1027
1028 base = expr->value.constructor;
1029 expr->value.constructor = NULL;
1030
1031 rank = ref->u.ar.as->rank;
1032
1033 if (expr->shape == NULL)
1034 expr->shape = gfc_get_shape (rank);
1035
1036 mpz_init_set_ui (delta_mpz, one);
1037 mpz_init_set_ui (nelts, one);
1038 mpz_init (tmp_mpz);
1039
1040 /* Do the initialization now, so that we can cleanup without
1041 keeping track of where we were. */
1042 for (d = 0; d < rank; d++)
1043 {
1044 mpz_init (delta[d]);
1045 mpz_init (start[d]);
1046 mpz_init (end[d]);
1047 mpz_init (ctr[d]);
1048 mpz_init (stride[d]);
1049 vecsub[d] = NULL;
1050 }
1051
1052 /* Build the counters to clock through the array reference. */
1053 shape_i = 0;
1054 for (d = 0; d < rank; d++)
1055 {
1056 /* Make this stretch of code easier on the eye! */
1057 begin = ref->u.ar.start[d];
1058 finish = ref->u.ar.end[d];
1059 step = ref->u.ar.stride[d];
1060 lower = ref->u.ar.as->lower[d];
1061 upper = ref->u.ar.as->upper[d];
1062
1063 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1064 {
1065 gcc_assert (begin);
1066 gcc_assert (begin->expr_type == EXPR_ARRAY);
1067 gcc_assert (begin->rank == 1);
1068 gcc_assert (begin->shape);
1069
1070 vecsub[d] = begin->value.constructor;
1071 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1072 mpz_mul (nelts, nelts, begin->shape[0]);
1073 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1074
1075 /* Check bounds. */
1076 for (c = vecsub[d]; c; c = c->next)
1077 {
1078 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1079 || mpz_cmp (c->expr->value.integer,
1080 lower->value.integer) < 0)
1081 {
1082 gfc_error ("index in dimension %d is out of bounds "
1083 "at %L", d + 1, &ref->u.ar.c_where[d]);
1084 t = FAILURE;
1085 goto cleanup;
1086 }
1087 }
1088 }
1089 else
1090 {
1091 if ((begin && begin->expr_type != EXPR_CONSTANT)
1092 || (finish && finish->expr_type != EXPR_CONSTANT)
1093 || (step && step->expr_type != EXPR_CONSTANT))
1094 {
1095 t = FAILURE;
1096 goto cleanup;
1097 }
1098
1099 /* Obtain the stride. */
1100 if (step)
1101 mpz_set (stride[d], step->value.integer);
1102 else
1103 mpz_set_ui (stride[d], one);
1104
1105 if (mpz_cmp_ui (stride[d], 0) == 0)
1106 mpz_set_ui (stride[d], one);
1107
1108 /* Obtain the start value for the index. */
1109 if (begin)
1110 mpz_set (start[d], begin->value.integer);
1111 else
1112 mpz_set (start[d], lower->value.integer);
1113
1114 mpz_set (ctr[d], start[d]);
1115
1116 /* Obtain the end value for the index. */
1117 if (finish)
1118 mpz_set (end[d], finish->value.integer);
1119 else
1120 mpz_set (end[d], upper->value.integer);
1121
1122 /* Separate 'if' because elements sometimes arrive with
1123 non-null end. */
1124 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1125 mpz_set (end [d], begin->value.integer);
1126
1127 /* Check the bounds. */
1128 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1129 || mpz_cmp (end[d], upper->value.integer) > 0
1130 || mpz_cmp (ctr[d], lower->value.integer) < 0
1131 || mpz_cmp (end[d], lower->value.integer) < 0)
1132 {
1133 gfc_error ("index in dimension %d is out of bounds "
1134 "at %L", d + 1, &ref->u.ar.c_where[d]);
1135 t = FAILURE;
1136 goto cleanup;
1137 }
1138
1139 /* Calculate the number of elements and the shape. */
1140 mpz_abs (tmp_mpz, stride[d]);
1141 mpz_div (tmp_mpz, stride[d], tmp_mpz);
1142 mpz_add (tmp_mpz, end[d], tmp_mpz);
1143 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1144 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1145 mpz_mul (nelts, nelts, tmp_mpz);
1146
1147 /* An element reference reduces the rank of the expression; don't
1148 add anything to the shape array. */
1149 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1150 mpz_set (expr->shape[shape_i++], tmp_mpz);
1151 }
1152
1153 /* Calculate the 'stride' (=delta) for conversion of the
1154 counter values into the index along the constructor. */
1155 mpz_set (delta[d], delta_mpz);
1156 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1157 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1158 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1159 }
1160
1161 mpz_init (index);
1162 mpz_init (ptr);
1163 cons = base;
1164
1165 /* Now clock through the array reference, calculating the index in
1166 the source constructor and transferring the elements to the new
1167 constructor. */
1168 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1169 {
1170 if (ref->u.ar.offset)
1171 mpz_set (ptr, ref->u.ar.offset->value.integer);
1172 else
1173 mpz_init_set_ui (ptr, 0);
1174
1175 incr_ctr = true;
1176 for (d = 0; d < rank; d++)
1177 {
1178 mpz_set (tmp_mpz, ctr[d]);
1179 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1180 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1181 mpz_add (ptr, ptr, tmp_mpz);
1182
1183 if (!incr_ctr) continue;
1184
1185 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1186 {
1187 gcc_assert(vecsub[d]);
1188
1189 if (!vecsub[d]->next)
1190 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1191 else
1192 {
1193 vecsub[d] = vecsub[d]->next;
1194 incr_ctr = false;
1195 }
1196 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1197 }
1198 else
1199 {
1200 mpz_add (ctr[d], ctr[d], stride[d]);
1201
1202 if (mpz_cmp_ui (stride[d], 0) > 0
1203 ? mpz_cmp (ctr[d], end[d]) > 0
1204 : mpz_cmp (ctr[d], end[d]) < 0)
1205 mpz_set (ctr[d], start[d]);
1206 else
1207 incr_ctr = false;
1208 }
1209 }
1210
1211 /* There must be a better way of dealing with negative strides
1212 than resetting the index and the constructor pointer! */
1213 if (mpz_cmp (ptr, index) < 0)
1214 {
1215 mpz_set_ui (index, 0);
1216 cons = base;
1217 }
1218
1219 while (mpz_cmp (ptr, index) > 0)
1220 {
1221 mpz_add_ui (index, index, one);
1222 cons = cons->next;
1223 }
1224
1225 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1226 }
1227
1228 mpz_clear (ptr);
1229 mpz_clear (index);
1230
1231 cleanup:
1232
1233 mpz_clear (delta_mpz);
1234 mpz_clear (tmp_mpz);
1235 mpz_clear (nelts);
1236 for (d = 0; d < rank; d++)
1237 {
1238 mpz_clear (delta[d]);
1239 mpz_clear (start[d]);
1240 mpz_clear (end[d]);
1241 mpz_clear (ctr[d]);
1242 mpz_clear (stride[d]);
1243 }
1244 gfc_free_constructor (base);
1245 return t;
1246 }
1247
1248 /* Pull a substring out of an expression. */
1249
1250 static try
1251 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1252 {
1253 int end;
1254 int start;
1255 char *chr;
1256
1257 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1258 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1259 return FAILURE;
1260
1261 *newp = gfc_copy_expr (p);
1262 chr = p->value.character.string;
1263 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1264 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1265
1266 (*newp)->value.character.length = end - start + 1;
1267 strncpy ((*newp)->value.character.string, &chr[start - 1],
1268 (*newp)->value.character.length);
1269 return SUCCESS;
1270 }
1271
1272
1273
1274 /* Simplify a subobject reference of a constructor. This occurs when
1275 parameter variable values are substituted. */
1276
1277 static try
1278 simplify_const_ref (gfc_expr *p)
1279 {
1280 gfc_constructor *cons;
1281 gfc_expr *newp;
1282
1283 while (p->ref)
1284 {
1285 switch (p->ref->type)
1286 {
1287 case REF_ARRAY:
1288 switch (p->ref->u.ar.type)
1289 {
1290 case AR_ELEMENT:
1291 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1292 &cons) == FAILURE)
1293 return FAILURE;
1294
1295 if (!cons)
1296 return SUCCESS;
1297
1298 remove_subobject_ref (p, cons);
1299 break;
1300
1301 case AR_SECTION:
1302 if (find_array_section (p, p->ref) == FAILURE)
1303 return FAILURE;
1304 p->ref->u.ar.type = AR_FULL;
1305
1306 /* FALLTHROUGH */
1307
1308 case AR_FULL:
1309 if (p->ref->next != NULL
1310 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1311 {
1312 cons = p->value.constructor;
1313 for (; cons; cons = cons->next)
1314 {
1315 cons->expr->ref = copy_ref (p->ref->next);
1316 simplify_const_ref (cons->expr);
1317 }
1318 }
1319 gfc_free_ref_list (p->ref);
1320 p->ref = NULL;
1321 break;
1322
1323 default:
1324 return SUCCESS;
1325 }
1326
1327 break;
1328
1329 case REF_COMPONENT:
1330 cons = find_component_ref (p->value.constructor, p->ref);
1331 remove_subobject_ref (p, cons);
1332 break;
1333
1334 case REF_SUBSTRING:
1335 if (find_substring_ref (p, &newp) == FAILURE)
1336 return FAILURE;
1337
1338 gfc_replace_expr (p, newp);
1339 gfc_free_ref_list (p->ref);
1340 p->ref = NULL;
1341 break;
1342 }
1343 }
1344
1345 return SUCCESS;
1346 }
1347
1348
1349 /* Simplify a chain of references. */
1350
1351 static try
1352 simplify_ref_chain (gfc_ref *ref, int type)
1353 {
1354 int n;
1355
1356 for (; ref; ref = ref->next)
1357 {
1358 switch (ref->type)
1359 {
1360 case REF_ARRAY:
1361 for (n = 0; n < ref->u.ar.dimen; n++)
1362 {
1363 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1364 return FAILURE;
1365 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1366 return FAILURE;
1367 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1368 return FAILURE;
1369 }
1370 break;
1371
1372 case REF_SUBSTRING:
1373 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1374 return FAILURE;
1375 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1376 return FAILURE;
1377 break;
1378
1379 default:
1380 break;
1381 }
1382 }
1383 return SUCCESS;
1384 }
1385
1386
1387 /* Try to substitute the value of a parameter variable. */
1388 static try
1389 simplify_parameter_variable (gfc_expr *p, int type)
1390 {
1391 gfc_expr *e;
1392 try t;
1393
1394 e = gfc_copy_expr (p->symtree->n.sym->value);
1395 if (e == NULL)
1396 return FAILURE;
1397
1398 e->rank = p->rank;
1399
1400 /* Do not copy subobject refs for constant. */
1401 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1402 e->ref = copy_ref (p->ref);
1403 t = gfc_simplify_expr (e, type);
1404
1405 /* Only use the simplification if it eliminated all subobject
1406 references. */
1407 if (t == SUCCESS && !e->ref)
1408 gfc_replace_expr (p, e);
1409 else
1410 gfc_free_expr (e);
1411
1412 return t;
1413 }
1414
1415 /* Given an expression, simplify it by collapsing constant
1416 expressions. Most simplification takes place when the expression
1417 tree is being constructed. If an intrinsic function is simplified
1418 at some point, we get called again to collapse the result against
1419 other constants.
1420
1421 We work by recursively simplifying expression nodes, simplifying
1422 intrinsic functions where possible, which can lead to further
1423 constant collapsing. If an operator has constant operand(s), we
1424 rip the expression apart, and rebuild it, hoping that it becomes
1425 something simpler.
1426
1427 The expression type is defined for:
1428 0 Basic expression parsing
1429 1 Simplifying array constructors -- will substitute
1430 iterator values.
1431 Returns FAILURE on error, SUCCESS otherwise.
1432 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1433
1434 try
1435 gfc_simplify_expr (gfc_expr *p, int type)
1436 {
1437 gfc_actual_arglist *ap;
1438
1439 if (p == NULL)
1440 return SUCCESS;
1441
1442 switch (p->expr_type)
1443 {
1444 case EXPR_CONSTANT:
1445 case EXPR_NULL:
1446 break;
1447
1448 case EXPR_FUNCTION:
1449 for (ap = p->value.function.actual; ap; ap = ap->next)
1450 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1451 return FAILURE;
1452
1453 if (p->value.function.isym != NULL
1454 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1455 return FAILURE;
1456
1457 break;
1458
1459 case EXPR_SUBSTRING:
1460 if (simplify_ref_chain (p->ref, type) == FAILURE)
1461 return FAILURE;
1462
1463 if (gfc_is_constant_expr (p))
1464 {
1465 char *s;
1466 int start, end;
1467
1468 gfc_extract_int (p->ref->u.ss.start, &start);
1469 start--; /* Convert from one-based to zero-based. */
1470 gfc_extract_int (p->ref->u.ss.end, &end);
1471 s = gfc_getmem (end - start + 2);
1472 memcpy (s, p->value.character.string + start, end - start);
1473 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1474 gfc_free (p->value.character.string);
1475 p->value.character.string = s;
1476 p->value.character.length = end - start;
1477 p->ts.cl = gfc_get_charlen ();
1478 p->ts.cl->next = gfc_current_ns->cl_list;
1479 gfc_current_ns->cl_list = p->ts.cl;
1480 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1481 gfc_free_ref_list (p->ref);
1482 p->ref = NULL;
1483 p->expr_type = EXPR_CONSTANT;
1484 }
1485 break;
1486
1487 case EXPR_OP:
1488 if (simplify_intrinsic_op (p, type) == FAILURE)
1489 return FAILURE;
1490 break;
1491
1492 case EXPR_VARIABLE:
1493 /* Only substitute array parameter variables if we are in an
1494 initialization expression, or we want a subsection. */
1495 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1496 && (gfc_init_expr || p->ref
1497 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1498 {
1499 if (simplify_parameter_variable (p, type) == FAILURE)
1500 return FAILURE;
1501 break;
1502 }
1503
1504 if (type == 1)
1505 {
1506 gfc_simplify_iterator_var (p);
1507 }
1508
1509 /* Simplify subcomponent references. */
1510 if (simplify_ref_chain (p->ref, type) == FAILURE)
1511 return FAILURE;
1512
1513 break;
1514
1515 case EXPR_STRUCTURE:
1516 case EXPR_ARRAY:
1517 if (simplify_ref_chain (p->ref, type) == FAILURE)
1518 return FAILURE;
1519
1520 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1521 return FAILURE;
1522
1523 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1524 && p->ref->u.ar.type == AR_FULL)
1525 gfc_expand_constructor (p);
1526
1527 if (simplify_const_ref (p) == FAILURE)
1528 return FAILURE;
1529
1530 break;
1531 }
1532
1533 return SUCCESS;
1534 }
1535
1536
1537 /* Returns the type of an expression with the exception that iterator
1538 variables are automatically integers no matter what else they may
1539 be declared as. */
1540
1541 static bt
1542 et0 (gfc_expr *e)
1543 {
1544 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1545 return BT_INTEGER;
1546
1547 return e->ts.type;
1548 }
1549
1550
1551 /* Check an intrinsic arithmetic operation to see if it is consistent
1552 with some type of expression. */
1553
1554 static try check_init_expr (gfc_expr *);
1555
1556 static try
1557 check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
1558 {
1559 gfc_expr *op1 = e->value.op.op1;
1560 gfc_expr *op2 = e->value.op.op2;
1561
1562 if ((*check_function) (op1) == FAILURE)
1563 return FAILURE;
1564
1565 switch (e->value.op.operator)
1566 {
1567 case INTRINSIC_UPLUS:
1568 case INTRINSIC_UMINUS:
1569 if (!numeric_type (et0 (op1)))
1570 goto not_numeric;
1571 break;
1572
1573 case INTRINSIC_EQ:
1574 case INTRINSIC_NE:
1575 case INTRINSIC_GT:
1576 case INTRINSIC_GE:
1577 case INTRINSIC_LT:
1578 case INTRINSIC_LE:
1579 if ((*check_function) (op2) == FAILURE)
1580 return FAILURE;
1581
1582 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1583 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1584 {
1585 gfc_error ("Numeric or CHARACTER operands are required in "
1586 "expression at %L", &e->where);
1587 return FAILURE;
1588 }
1589 break;
1590
1591 case INTRINSIC_PLUS:
1592 case INTRINSIC_MINUS:
1593 case INTRINSIC_TIMES:
1594 case INTRINSIC_DIVIDE:
1595 case INTRINSIC_POWER:
1596 if ((*check_function) (op2) == FAILURE)
1597 return FAILURE;
1598
1599 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1600 goto not_numeric;
1601
1602 if (e->value.op.operator == INTRINSIC_POWER
1603 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1604 {
1605 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1606 "exponent in an initialization "
1607 "expression at %L", &op2->where)
1608 == FAILURE)
1609 return FAILURE;
1610 }
1611
1612 break;
1613
1614 case INTRINSIC_CONCAT:
1615 if ((*check_function) (op2) == FAILURE)
1616 return FAILURE;
1617
1618 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1619 {
1620 gfc_error ("Concatenation operator in expression at %L "
1621 "must have two CHARACTER operands", &op1->where);
1622 return FAILURE;
1623 }
1624
1625 if (op1->ts.kind != op2->ts.kind)
1626 {
1627 gfc_error ("Concat operator at %L must concatenate strings of the "
1628 "same kind", &e->where);
1629 return FAILURE;
1630 }
1631
1632 break;
1633
1634 case INTRINSIC_NOT:
1635 if (et0 (op1) != BT_LOGICAL)
1636 {
1637 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1638 "operand", &op1->where);
1639 return FAILURE;
1640 }
1641
1642 break;
1643
1644 case INTRINSIC_AND:
1645 case INTRINSIC_OR:
1646 case INTRINSIC_EQV:
1647 case INTRINSIC_NEQV:
1648 if ((*check_function) (op2) == FAILURE)
1649 return FAILURE;
1650
1651 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1652 {
1653 gfc_error ("LOGICAL operands are required in expression at %L",
1654 &e->where);
1655 return FAILURE;
1656 }
1657
1658 break;
1659
1660 case INTRINSIC_PARENTHESES:
1661 break;
1662
1663 default:
1664 gfc_error ("Only intrinsic operators can be used in expression at %L",
1665 &e->where);
1666 return FAILURE;
1667 }
1668
1669 return SUCCESS;
1670
1671 not_numeric:
1672 gfc_error ("Numeric operands are required in expression at %L", &e->where);
1673
1674 return FAILURE;
1675 }
1676
1677
1678
1679 /* Certain inquiry functions are specifically allowed to have variable
1680 arguments, which is an exception to the normal requirement that an
1681 initialization function have initialization arguments. We head off
1682 this problem here. */
1683
1684 static try
1685 check_inquiry (gfc_expr *e, int not_restricted)
1686 {
1687 const char *name;
1688
1689 /* FIXME: This should be moved into the intrinsic definitions,
1690 to eliminate this ugly hack. */
1691 static const char * const inquiry_function[] = {
1692 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1693 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1694 "lbound", "ubound", NULL
1695 };
1696
1697 int i;
1698
1699 /* An undeclared parameter will get us here (PR25018). */
1700 if (e->symtree == NULL)
1701 return FAILURE;
1702
1703 name = e->symtree->n.sym->name;
1704
1705 for (i = 0; inquiry_function[i]; i++)
1706 if (strcmp (inquiry_function[i], name) == 0)
1707 break;
1708
1709 if (inquiry_function[i] == NULL)
1710 return FAILURE;
1711
1712 e = e->value.function.actual->expr;
1713
1714 if (e == NULL || e->expr_type != EXPR_VARIABLE)
1715 return FAILURE;
1716
1717 /* At this point we have an inquiry function with a variable argument. The
1718 type of the variable might be undefined, but we need it now, because the
1719 arguments of these functions are allowed to be undefined. */
1720
1721 if (e->ts.type == BT_UNKNOWN)
1722 {
1723 if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1724 && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1725 == FAILURE)
1726 return FAILURE;
1727
1728 e->ts = e->symtree->n.sym->ts;
1729 }
1730
1731 /* Assumed character length will not reduce to a constant expression
1732 with LEN, as required by the standard. */
1733 if (i == 4 && not_restricted
1734 && e->symtree->n.sym->ts.type == BT_CHARACTER
1735 && e->symtree->n.sym->ts.cl->length == NULL)
1736 gfc_notify_std (GFC_STD_GNU, "assumed character length "
1737 "variable '%s' in constant expression at %L",
1738 e->symtree->n.sym->name, &e->where);
1739
1740 return SUCCESS;
1741 }
1742
1743
1744 /* Verify that an expression is an initialization expression. A side
1745 effect is that the expression tree is reduced to a single constant
1746 node if all goes well. This would normally happen when the
1747 expression is constructed but function references are assumed to be
1748 intrinsics in the context of initialization expressions. If
1749 FAILURE is returned an error message has been generated. */
1750
1751 static try
1752 check_init_expr (gfc_expr *e)
1753 {
1754 gfc_actual_arglist *ap;
1755 match m;
1756 try t;
1757
1758 if (e == NULL)
1759 return SUCCESS;
1760
1761 switch (e->expr_type)
1762 {
1763 case EXPR_OP:
1764 t = check_intrinsic_op (e, check_init_expr);
1765 if (t == SUCCESS)
1766 t = gfc_simplify_expr (e, 0);
1767
1768 break;
1769
1770 case EXPR_FUNCTION:
1771 t = SUCCESS;
1772
1773 if (check_inquiry (e, 1) != SUCCESS)
1774 {
1775 t = SUCCESS;
1776 for (ap = e->value.function.actual; ap; ap = ap->next)
1777 if (check_init_expr (ap->expr) == FAILURE)
1778 {
1779 t = FAILURE;
1780 break;
1781 }
1782 }
1783
1784 if (t == SUCCESS)
1785 {
1786 m = gfc_intrinsic_func_interface (e, 0);
1787
1788 if (m == MATCH_NO)
1789 gfc_error ("Function '%s' in initialization expression at %L "
1790 "must be an intrinsic function",
1791 e->symtree->n.sym->name, &e->where);
1792
1793 if (m != MATCH_YES)
1794 t = FAILURE;
1795 }
1796
1797 break;
1798
1799 case EXPR_VARIABLE:
1800 t = SUCCESS;
1801
1802 if (gfc_check_iter_variable (e) == SUCCESS)
1803 break;
1804
1805 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1806 {
1807 t = simplify_parameter_variable (e, 0);
1808 break;
1809 }
1810
1811 if (gfc_in_match_data ())
1812 break;
1813
1814 gfc_error ("Parameter '%s' at %L has not been declared or is "
1815 "a variable, which does not reduce to a constant "
1816 "expression", e->symtree->n.sym->name, &e->where);
1817 t = FAILURE;
1818 break;
1819
1820 case EXPR_CONSTANT:
1821 case EXPR_NULL:
1822 t = SUCCESS;
1823 break;
1824
1825 case EXPR_SUBSTRING:
1826 t = check_init_expr (e->ref->u.ss.start);
1827 if (t == FAILURE)
1828 break;
1829
1830 t = check_init_expr (e->ref->u.ss.end);
1831 if (t == SUCCESS)
1832 t = gfc_simplify_expr (e, 0);
1833
1834 break;
1835
1836 case EXPR_STRUCTURE:
1837 t = gfc_check_constructor (e, check_init_expr);
1838 break;
1839
1840 case EXPR_ARRAY:
1841 t = gfc_check_constructor (e, check_init_expr);
1842 if (t == FAILURE)
1843 break;
1844
1845 t = gfc_expand_constructor (e);
1846 if (t == FAILURE)
1847 break;
1848
1849 t = gfc_check_constructor_type (e);
1850 break;
1851
1852 default:
1853 gfc_internal_error ("check_init_expr(): Unknown expression type");
1854 }
1855
1856 return t;
1857 }
1858
1859
1860 /* Match an initialization expression. We work by first matching an
1861 expression, then reducing it to a constant. */
1862
1863 match
1864 gfc_match_init_expr (gfc_expr **result)
1865 {
1866 gfc_expr *expr;
1867 match m;
1868 try t;
1869
1870 m = gfc_match_expr (&expr);
1871 if (m != MATCH_YES)
1872 return m;
1873
1874 gfc_init_expr = 1;
1875 t = gfc_resolve_expr (expr);
1876 if (t == SUCCESS)
1877 t = check_init_expr (expr);
1878 gfc_init_expr = 0;
1879
1880 if (t == FAILURE)
1881 {
1882 gfc_free_expr (expr);
1883 return MATCH_ERROR;
1884 }
1885
1886 if (expr->expr_type == EXPR_ARRAY
1887 && (gfc_check_constructor_type (expr) == FAILURE
1888 || gfc_expand_constructor (expr) == FAILURE))
1889 {
1890 gfc_free_expr (expr);
1891 return MATCH_ERROR;
1892 }
1893
1894 /* Not all inquiry functions are simplified to constant expressions
1895 so it is necessary to call check_inquiry again. */
1896 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) == FAILURE
1897 && !gfc_in_match_data ())
1898 {
1899 gfc_error ("Initialization expression didn't reduce %C");
1900 return MATCH_ERROR;
1901 }
1902
1903 *result = expr;
1904
1905 return MATCH_YES;
1906 }
1907
1908
1909 static try check_restricted (gfc_expr *);
1910
1911 /* Given an actual argument list, test to see that each argument is a
1912 restricted expression and optionally if the expression type is
1913 integer or character. */
1914
1915 static try
1916 restricted_args (gfc_actual_arglist *a)
1917 {
1918 for (; a; a = a->next)
1919 {
1920 if (check_restricted (a->expr) == FAILURE)
1921 return FAILURE;
1922 }
1923
1924 return SUCCESS;
1925 }
1926
1927
1928 /************* Restricted/specification expressions *************/
1929
1930
1931 /* Make sure a non-intrinsic function is a specification function. */
1932
1933 static try
1934 external_spec_function (gfc_expr *e)
1935 {
1936 gfc_symbol *f;
1937
1938 f = e->value.function.esym;
1939
1940 if (f->attr.proc == PROC_ST_FUNCTION)
1941 {
1942 gfc_error ("Specification function '%s' at %L cannot be a statement "
1943 "function", f->name, &e->where);
1944 return FAILURE;
1945 }
1946
1947 if (f->attr.proc == PROC_INTERNAL)
1948 {
1949 gfc_error ("Specification function '%s' at %L cannot be an internal "
1950 "function", f->name, &e->where);
1951 return FAILURE;
1952 }
1953
1954 if (!f->attr.pure && !f->attr.elemental)
1955 {
1956 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1957 &e->where);
1958 return FAILURE;
1959 }
1960
1961 if (f->attr.recursive)
1962 {
1963 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1964 f->name, &e->where);
1965 return FAILURE;
1966 }
1967
1968 return restricted_args (e->value.function.actual);
1969 }
1970
1971
1972 /* Check to see that a function reference to an intrinsic is a
1973 restricted expression. */
1974
1975 static try
1976 restricted_intrinsic (gfc_expr *e)
1977 {
1978 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1979 if (check_inquiry (e, 0) == SUCCESS)
1980 return SUCCESS;
1981
1982 return restricted_args (e->value.function.actual);
1983 }
1984
1985
1986 /* Verify that an expression is a restricted expression. Like its
1987 cousin check_init_expr(), an error message is generated if we
1988 return FAILURE. */
1989
1990 static try
1991 check_restricted (gfc_expr *e)
1992 {
1993 gfc_symbol *sym;
1994 try t;
1995
1996 if (e == NULL)
1997 return SUCCESS;
1998
1999 switch (e->expr_type)
2000 {
2001 case EXPR_OP:
2002 t = check_intrinsic_op (e, check_restricted);
2003 if (t == SUCCESS)
2004 t = gfc_simplify_expr (e, 0);
2005
2006 break;
2007
2008 case EXPR_FUNCTION:
2009 t = e->value.function.esym ? external_spec_function (e)
2010 : restricted_intrinsic (e);
2011
2012 break;
2013
2014 case EXPR_VARIABLE:
2015 sym = e->symtree->n.sym;
2016 t = FAILURE;
2017
2018 if (sym->attr.optional)
2019 {
2020 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2021 sym->name, &e->where);
2022 break;
2023 }
2024
2025 if (sym->attr.intent == INTENT_OUT)
2026 {
2027 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2028 sym->name, &e->where);
2029 break;
2030 }
2031
2032 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2033 processed in resolve.c(resolve_formal_arglist). This is done so
2034 that host associated dummy array indices are accepted (PR23446).
2035 This mechanism also does the same for the specification expressions
2036 of array-valued functions. */
2037 if (sym->attr.in_common
2038 || sym->attr.use_assoc
2039 || sym->attr.dummy
2040 || sym->ns != gfc_current_ns
2041 || (sym->ns->proc_name != NULL
2042 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2043 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2044 {
2045 t = SUCCESS;
2046 break;
2047 }
2048
2049 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2050 sym->name, &e->where);
2051
2052 break;
2053
2054 case EXPR_NULL:
2055 case EXPR_CONSTANT:
2056 t = SUCCESS;
2057 break;
2058
2059 case EXPR_SUBSTRING:
2060 t = gfc_specification_expr (e->ref->u.ss.start);
2061 if (t == FAILURE)
2062 break;
2063
2064 t = gfc_specification_expr (e->ref->u.ss.end);
2065 if (t == SUCCESS)
2066 t = gfc_simplify_expr (e, 0);
2067
2068 break;
2069
2070 case EXPR_STRUCTURE:
2071 t = gfc_check_constructor (e, check_restricted);
2072 break;
2073
2074 case EXPR_ARRAY:
2075 t = gfc_check_constructor (e, check_restricted);
2076 break;
2077
2078 default:
2079 gfc_internal_error ("check_restricted(): Unknown expression type");
2080 }
2081
2082 return t;
2083 }
2084
2085
2086 /* Check to see that an expression is a specification expression. If
2087 we return FAILURE, an error has been generated. */
2088
2089 try
2090 gfc_specification_expr (gfc_expr *e)
2091 {
2092 if (e == NULL)
2093 return SUCCESS;
2094
2095 if (e->ts.type != BT_INTEGER)
2096 {
2097 gfc_error ("Expression at %L must be of INTEGER type", &e->where);
2098 return FAILURE;
2099 }
2100
2101 if (e->rank != 0)
2102 {
2103 gfc_error ("Expression at %L must be scalar", &e->where);
2104 return FAILURE;
2105 }
2106
2107 if (gfc_simplify_expr (e, 0) == FAILURE)
2108 return FAILURE;
2109
2110 return check_restricted (e);
2111 }
2112
2113
2114 /************** Expression conformance checks. *************/
2115
2116 /* Given two expressions, make sure that the arrays are conformable. */
2117
2118 try
2119 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2120 {
2121 int op1_flag, op2_flag, d;
2122 mpz_t op1_size, op2_size;
2123 try t;
2124
2125 if (op1->rank == 0 || op2->rank == 0)
2126 return SUCCESS;
2127
2128 if (op1->rank != op2->rank)
2129 {
2130 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
2131 &op1->where);
2132 return FAILURE;
2133 }
2134
2135 t = SUCCESS;
2136
2137 for (d = 0; d < op1->rank; d++)
2138 {
2139 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2140 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2141
2142 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2143 {
2144 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2145 _(optype_msgid), &op1->where, d + 1,
2146 (int) mpz_get_si (op1_size),
2147 (int) mpz_get_si (op2_size));
2148
2149 t = FAILURE;
2150 }
2151
2152 if (op1_flag)
2153 mpz_clear (op1_size);
2154 if (op2_flag)
2155 mpz_clear (op2_size);
2156
2157 if (t == FAILURE)
2158 return FAILURE;
2159 }
2160
2161 return SUCCESS;
2162 }
2163
2164
2165 /* Given an assignable expression and an arbitrary expression, make
2166 sure that the assignment can take place. */
2167
2168 try
2169 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2170 {
2171 gfc_symbol *sym;
2172 gfc_ref *ref;
2173 int has_pointer;
2174
2175 sym = lvalue->symtree->n.sym;
2176
2177 /* Check INTENT(IN), unless the object itself is the component or
2178 sub-component of a pointer. */
2179 has_pointer = sym->attr.pointer;
2180
2181 for (ref = lvalue->ref; ref; ref = ref->next)
2182 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2183 {
2184 has_pointer = 1;
2185 break;
2186 }
2187
2188 if (!has_pointer && sym->attr.intent == INTENT_IN)
2189 {
2190 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2191 sym->name, &lvalue->where);
2192 return FAILURE;
2193 }
2194
2195 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2196 variable local to a function subprogram. Its existence begins when
2197 execution of the function is initiated and ends when execution of the
2198 function is terminated.....
2199 Therefore, the left hand side is no longer a varaiable, when it is: */
2200 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2201 && !sym->attr.external)
2202 {
2203 bool bad_proc;
2204 bad_proc = false;
2205
2206 /* (i) Use associated; */
2207 if (sym->attr.use_assoc)
2208 bad_proc = true;
2209
2210 /* (ii) The assignment is in the main program; or */
2211 if (gfc_current_ns->proc_name->attr.is_main_program)
2212 bad_proc = true;
2213
2214 /* (iii) A module or internal procedure.... */
2215 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2216 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2217 && gfc_current_ns->parent
2218 && (!(gfc_current_ns->parent->proc_name->attr.function
2219 || gfc_current_ns->parent->proc_name->attr.subroutine)
2220 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2221 {
2222 /* .... that is not a function.... */
2223 if (!gfc_current_ns->proc_name->attr.function)
2224 bad_proc = true;
2225
2226 /* .... or is not an entry and has a different name. */
2227 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2228 bad_proc = true;
2229 }
2230
2231 if (bad_proc)
2232 {
2233 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2234 return FAILURE;
2235 }
2236 }
2237
2238 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2239 {
2240 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2241 lvalue->rank, rvalue->rank, &lvalue->where);
2242 return FAILURE;
2243 }
2244
2245 if (lvalue->ts.type == BT_UNKNOWN)
2246 {
2247 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2248 &lvalue->where);
2249 return FAILURE;
2250 }
2251
2252 if (rvalue->expr_type == EXPR_NULL)
2253 {
2254 gfc_error ("NULL appears on right-hand side in assignment at %L",
2255 &rvalue->where);
2256 return FAILURE;
2257 }
2258
2259 if (sym->attr.cray_pointee
2260 && lvalue->ref != NULL
2261 && lvalue->ref->u.ar.type == AR_FULL
2262 && lvalue->ref->u.ar.as->cp_was_assumed)
2263 {
2264 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2265 "is illegal", &lvalue->where);
2266 return FAILURE;
2267 }
2268
2269 /* This is possibly a typo: x = f() instead of x => f() */
2270 if (gfc_option.warn_surprising
2271 && rvalue->expr_type == EXPR_FUNCTION
2272 && rvalue->symtree->n.sym->attr.pointer)
2273 gfc_warning ("POINTER valued function appears on right-hand side of "
2274 "assignment at %L", &rvalue->where);
2275
2276 /* Check size of array assignments. */
2277 if (lvalue->rank != 0 && rvalue->rank != 0
2278 && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
2279 return FAILURE;
2280
2281 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2282 return SUCCESS;
2283
2284 if (!conform)
2285 {
2286 /* Numeric can be converted to any other numeric. And Hollerith can be
2287 converted to any other type. */
2288 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2289 || rvalue->ts.type == BT_HOLLERITH)
2290 return SUCCESS;
2291
2292 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2293 return SUCCESS;
2294
2295 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2296 &rvalue->where, gfc_typename (&rvalue->ts),
2297 gfc_typename (&lvalue->ts));
2298
2299 return FAILURE;
2300 }
2301
2302 return gfc_convert_type (rvalue, &lvalue->ts, 1);
2303 }
2304
2305
2306 /* Check that a pointer assignment is OK. We first check lvalue, and
2307 we only check rvalue if it's not an assignment to NULL() or a
2308 NULLIFY statement. */
2309
2310 try
2311 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
2312 {
2313 symbol_attribute attr;
2314 gfc_ref *ref;
2315 int is_pure;
2316 int pointer, check_intent_in;
2317
2318 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
2319 {
2320 gfc_error ("Pointer assignment target is not a POINTER at %L",
2321 &lvalue->where);
2322 return FAILURE;
2323 }
2324
2325 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
2326 && lvalue->symtree->n.sym->attr.use_assoc)
2327 {
2328 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2329 "l-value since it is a procedure",
2330 lvalue->symtree->n.sym->name, &lvalue->where);
2331 return FAILURE;
2332 }
2333
2334
2335 /* Check INTENT(IN), unless the object itself is the component or
2336 sub-component of a pointer. */
2337 check_intent_in = 1;
2338 pointer = lvalue->symtree->n.sym->attr.pointer;
2339
2340 for (ref = lvalue->ref; ref; ref = ref->next)
2341 {
2342 if (pointer)
2343 check_intent_in = 0;
2344
2345 if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2346 pointer = 1;
2347 }
2348
2349 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
2350 {
2351 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2352 lvalue->symtree->n.sym->name, &lvalue->where);
2353 return FAILURE;
2354 }
2355
2356 if (!pointer)
2357 {
2358 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
2359 return FAILURE;
2360 }
2361
2362 is_pure = gfc_pure (NULL);
2363
2364 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
2365 {
2366 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
2367 return FAILURE;
2368 }
2369
2370 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2371 kind, etc for lvalue and rvalue must match, and rvalue must be a
2372 pure variable if we're in a pure function. */
2373 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
2374 return SUCCESS;
2375
2376 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
2377 {
2378 gfc_error ("Different types in pointer assignment at %L",
2379 &lvalue->where);
2380 return FAILURE;
2381 }
2382
2383 if (lvalue->ts.kind != rvalue->ts.kind)
2384 {
2385 gfc_error ("Different kind type parameters in pointer "
2386 "assignment at %L", &lvalue->where);
2387 return FAILURE;
2388 }
2389
2390 if (lvalue->rank != rvalue->rank)
2391 {
2392 gfc_error ("Different ranks in pointer assignment at %L",
2393 &lvalue->where);
2394 return FAILURE;
2395 }
2396
2397 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2398 if (rvalue->expr_type == EXPR_NULL)
2399 return SUCCESS;
2400
2401 if (lvalue->ts.type == BT_CHARACTER
2402 && lvalue->ts.cl->length && rvalue->ts.cl->length
2403 && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2404 rvalue->ts.cl->length)) == 1)
2405 {
2406 gfc_error ("Different character lengths in pointer "
2407 "assignment at %L", &lvalue->where);
2408 return FAILURE;
2409 }
2410
2411 attr = gfc_expr_attr (rvalue);
2412 if (!attr.target && !attr.pointer)
2413 {
2414 gfc_error ("Pointer assignment target is neither TARGET "
2415 "nor POINTER at %L", &rvalue->where);
2416 return FAILURE;
2417 }
2418
2419 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2420 {
2421 gfc_error ("Bad target in pointer assignment in PURE "
2422 "procedure at %L", &rvalue->where);
2423 }
2424
2425 if (gfc_has_vector_index (rvalue))
2426 {
2427 gfc_error ("Pointer assignment with vector subscript "
2428 "on rhs at %L", &rvalue->where);
2429 return FAILURE;
2430 }
2431
2432 if (attr.protected && attr.use_assoc)
2433 {
2434 gfc_error ("Pointer assigment target has PROTECTED "
2435 "attribute at %L", &rvalue->where);
2436 return FAILURE;
2437 }
2438
2439 return SUCCESS;
2440 }
2441
2442
2443 /* Relative of gfc_check_assign() except that the lvalue is a single
2444 symbol. Used for initialization assignments. */
2445
2446 try
2447 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
2448 {
2449 gfc_expr lvalue;
2450 try r;
2451
2452 memset (&lvalue, '\0', sizeof (gfc_expr));
2453
2454 lvalue.expr_type = EXPR_VARIABLE;
2455 lvalue.ts = sym->ts;
2456 if (sym->as)
2457 lvalue.rank = sym->as->rank;
2458 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
2459 lvalue.symtree->n.sym = sym;
2460 lvalue.where = sym->declared_at;
2461
2462 if (sym->attr.pointer)
2463 r = gfc_check_pointer_assign (&lvalue, rvalue);
2464 else
2465 r = gfc_check_assign (&lvalue, rvalue, 1);
2466
2467 gfc_free (lvalue.symtree);
2468
2469 return r;
2470 }
2471
2472
2473 /* Get an expression for a default initializer. */
2474
2475 gfc_expr *
2476 gfc_default_initializer (gfc_typespec *ts)
2477 {
2478 gfc_constructor *tail;
2479 gfc_expr *init;
2480 gfc_component *c;
2481
2482 init = NULL;
2483
2484 /* See if we have a default initializer. */
2485 for (c = ts->derived->components; c; c = c->next)
2486 {
2487 if ((c->initializer || c->allocatable) && init == NULL)
2488 init = gfc_get_expr ();
2489 }
2490
2491 if (init == NULL)
2492 return NULL;
2493
2494 /* Build the constructor. */
2495 init->expr_type = EXPR_STRUCTURE;
2496 init->ts = *ts;
2497 init->where = ts->derived->declared_at;
2498 tail = NULL;
2499 for (c = ts->derived->components; c; c = c->next)
2500 {
2501 if (tail == NULL)
2502 init->value.constructor = tail = gfc_get_constructor ();
2503 else
2504 {
2505 tail->next = gfc_get_constructor ();
2506 tail = tail->next;
2507 }
2508
2509 if (c->initializer)
2510 tail->expr = gfc_copy_expr (c->initializer);
2511
2512 if (c->allocatable)
2513 {
2514 tail->expr = gfc_get_expr ();
2515 tail->expr->expr_type = EXPR_NULL;
2516 tail->expr->ts = c->ts;
2517 }
2518 }
2519 return init;
2520 }
2521
2522
2523 /* Given a symbol, create an expression node with that symbol as a
2524 variable. If the symbol is array valued, setup a reference of the
2525 whole array. */
2526
2527 gfc_expr *
2528 gfc_get_variable_expr (gfc_symtree *var)
2529 {
2530 gfc_expr *e;
2531
2532 e = gfc_get_expr ();
2533 e->expr_type = EXPR_VARIABLE;
2534 e->symtree = var;
2535 e->ts = var->n.sym->ts;
2536
2537 if (var->n.sym->as != NULL)
2538 {
2539 e->rank = var->n.sym->as->rank;
2540 e->ref = gfc_get_ref ();
2541 e->ref->type = REF_ARRAY;
2542 e->ref->u.ar.type = AR_FULL;
2543 }
2544
2545 return e;
2546 }
2547
2548
2549 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2550
2551 void
2552 gfc_expr_set_symbols_referenced (gfc_expr *expr)
2553 {
2554 gfc_actual_arglist *arg;
2555 gfc_constructor *c;
2556 gfc_ref *ref;
2557 int i;
2558
2559 if (!expr) return;
2560
2561 switch (expr->expr_type)
2562 {
2563 case EXPR_OP:
2564 gfc_expr_set_symbols_referenced (expr->value.op.op1);
2565 gfc_expr_set_symbols_referenced (expr->value.op.op2);
2566 break;
2567
2568 case EXPR_FUNCTION:
2569 for (arg = expr->value.function.actual; arg; arg = arg->next)
2570 gfc_expr_set_symbols_referenced (arg->expr);
2571 break;
2572
2573 case EXPR_VARIABLE:
2574 gfc_set_sym_referenced (expr->symtree->n.sym);
2575 break;
2576
2577 case EXPR_CONSTANT:
2578 case EXPR_NULL:
2579 case EXPR_SUBSTRING:
2580 break;
2581
2582 case EXPR_STRUCTURE:
2583 case EXPR_ARRAY:
2584 for (c = expr->value.constructor; c; c = c->next)
2585 gfc_expr_set_symbols_referenced (c->expr);
2586 break;
2587
2588 default:
2589 gcc_unreachable ();
2590 break;
2591 }
2592
2593 for (ref = expr->ref; ref; ref = ref->next)
2594 switch (ref->type)
2595 {
2596 case REF_ARRAY:
2597 for (i = 0; i < ref->u.ar.dimen; i++)
2598 {
2599 gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2600 gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2601 gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2602 }
2603 break;
2604
2605 case REF_COMPONENT:
2606 break;
2607
2608 case REF_SUBSTRING:
2609 gfc_expr_set_symbols_referenced (ref->u.ss.start);
2610 gfc_expr_set_symbols_referenced (ref->u.ss.end);
2611 break;
2612
2613 default:
2614 gcc_unreachable ();
2615 break;
2616 }
2617 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org