?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR rtl-optimization/43520
[official-gcc.git] / gcc / fortran / check.c
blob799b8c9feeac0f533b28aaaae50049d679180f86
1 /* Check functions
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
28
29 #include "config.h"
30 #include "system.h"
31 #include "flags.h"
32 #include "gfortran.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35
36
37 /* Make sure an expression is a scalar. */
38
39 static gfc_try
40 scalar_check (gfc_expr *e, int n)
41 {
42 if (e->rank == 0)
43 return SUCCESS;
44
45 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
46 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
47
48 return FAILURE;
49 }
50
51
52 /* Check the type of an expression. */
53
54 static gfc_try
55 type_check (gfc_expr *e, int n, bt type)
56 {
57 if (e->ts.type == type)
58 return SUCCESS;
59
60 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
61 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
62 gfc_basic_typename (type));
63
64 return FAILURE;
65 }
66
67
68 /* Check that the expression is a numeric type. */
69
70 static gfc_try
71 numeric_check (gfc_expr *e, int n)
72 {
73 if (gfc_numeric_ts (&e->ts))
74 return SUCCESS;
75
76 /* If the expression has not got a type, check if its namespace can
77 offer a default type. */
78 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
79 && e->symtree->n.sym->ts.type == BT_UNKNOWN
80 && gfc_set_default_type (e->symtree->n.sym, 0,
81 e->symtree->n.sym->ns) == SUCCESS
82 && gfc_numeric_ts (&e->symtree->n.sym->ts))
83 {
84 e->ts = e->symtree->n.sym->ts;
85 return SUCCESS;
86 }
87
88 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
89 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
90
91 return FAILURE;
92 }
93
94
95 /* Check that an expression is integer or real. */
96
97 static gfc_try
98 int_or_real_check (gfc_expr *e, int n)
99 {
100 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
101 {
102 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
103 "or REAL", gfc_current_intrinsic_arg[n],
104 gfc_current_intrinsic, &e->where);
105 return FAILURE;
106 }
107
108 return SUCCESS;
109 }
110
111
112 /* Check that an expression is real or complex. */
113
114 static gfc_try
115 real_or_complex_check (gfc_expr *e, int n)
116 {
117 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
118 {
119 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
120 "or COMPLEX", gfc_current_intrinsic_arg[n],
121 gfc_current_intrinsic, &e->where);
122 return FAILURE;
123 }
124
125 return SUCCESS;
126 }
127
128
129 /* Check that the expression is an optional constant integer
130 and that it specifies a valid kind for that type. */
131
132 static gfc_try
133 kind_check (gfc_expr *k, int n, bt type)
134 {
135 int kind;
136
137 if (k == NULL)
138 return SUCCESS;
139
140 if (type_check (k, n, BT_INTEGER) == FAILURE)
141 return FAILURE;
142
143 if (scalar_check (k, n) == FAILURE)
144 return FAILURE;
145
146 if (k->expr_type != EXPR_CONSTANT)
147 {
148 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
149 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
150 &k->where);
151 return FAILURE;
152 }
153
154 if (gfc_extract_int (k, &kind) != NULL
155 || gfc_validate_kind (type, kind, true) < 0)
156 {
157 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
158 &k->where);
159 return FAILURE;
160 }
161
162 return SUCCESS;
163 }
164
165
166 /* Make sure the expression is a double precision real. */
167
168 static gfc_try
169 double_check (gfc_expr *d, int n)
170 {
171 if (type_check (d, n, BT_REAL) == FAILURE)
172 return FAILURE;
173
174 if (d->ts.kind != gfc_default_double_kind)
175 {
176 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
177 "precision", gfc_current_intrinsic_arg[n],
178 gfc_current_intrinsic, &d->where);
179 return FAILURE;
180 }
181
182 return SUCCESS;
183 }
184
185
186 /* Check whether an expression is a coarray (without array designator). */
187
188 static bool
189 is_coarray (gfc_expr *e)
190 {
191 bool coarray = false;
192 gfc_ref *ref;
193
194 if (e->expr_type != EXPR_VARIABLE)
195 return false;
196
197 coarray = e->symtree->n.sym->attr.codimension;
198
199 for (ref = e->ref; ref; ref = ref->next)
200 {
201 if (ref->type == REF_COMPONENT)
202 coarray = ref->u.c.component->attr.codimension;
203 else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
204 || ref->u.ar.codimen != 0)
205 coarray = false;
206 }
207
208 return coarray;
209 }
210
211
212 /* Make sure the expression is a logical array. */
213
214 static gfc_try
215 logical_array_check (gfc_expr *array, int n)
216 {
217 if (array->ts.type != BT_LOGICAL || array->rank == 0)
218 {
219 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
220 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
221 &array->where);
222 return FAILURE;
223 }
224
225 return SUCCESS;
226 }
227
228
229 /* Make sure an expression is an array. */
230
231 static gfc_try
232 array_check (gfc_expr *e, int n)
233 {
234 if (e->rank != 0)
235 return SUCCESS;
236
237 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
238 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
239
240 return FAILURE;
241 }
242
243
244 /* Make sure two expressions have the same type. */
245
246 static gfc_try
247 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
248 {
249 if (gfc_compare_types (&e->ts, &f->ts))
250 return SUCCESS;
251
252 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
253 "and kind as '%s'", gfc_current_intrinsic_arg[m],
254 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
255
256 return FAILURE;
257 }
258
259
260 /* Make sure that an expression has a certain (nonzero) rank. */
261
262 static gfc_try
263 rank_check (gfc_expr *e, int n, int rank)
264 {
265 if (e->rank == rank)
266 return SUCCESS;
267
268 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
269 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
270 &e->where, rank);
271
272 return FAILURE;
273 }
274
275
276 /* Make sure a variable expression is not an optional dummy argument. */
277
278 static gfc_try
279 nonoptional_check (gfc_expr *e, int n)
280 {
281 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
282 {
283 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
284 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
285 &e->where);
286 }
287
288 /* TODO: Recursive check on nonoptional variables? */
289
290 return SUCCESS;
291 }
292
293
294 /* Check that an expression has a particular kind. */
295
296 static gfc_try
297 kind_value_check (gfc_expr *e, int n, int k)
298 {
299 if (e->ts.kind == k)
300 return SUCCESS;
301
302 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
303 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
304 &e->where, k);
305
306 return FAILURE;
307 }
308
309
310 /* Make sure an expression is a variable. */
311
312 static gfc_try
313 variable_check (gfc_expr *e, int n)
314 {
315 if ((e->expr_type == EXPR_VARIABLE
316 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
317 || (e->expr_type == EXPR_FUNCTION
318 && e->symtree->n.sym->result == e->symtree->n.sym))
319 return SUCCESS;
320
321 if (e->expr_type == EXPR_VARIABLE
322 && e->symtree->n.sym->attr.intent == INTENT_IN)
323 {
324 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
325 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
326 &e->where);
327 return FAILURE;
328 }
329
330 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
331 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
332
333 return FAILURE;
334 }
335
336
337 /* Check the common DIM parameter for correctness. */
338
339 static gfc_try
340 dim_check (gfc_expr *dim, int n, bool optional)
341 {
342 if (dim == NULL)
343 return SUCCESS;
344
345 if (type_check (dim, n, BT_INTEGER) == FAILURE)
346 return FAILURE;
347
348 if (scalar_check (dim, n) == FAILURE)
349 return FAILURE;
350
351 if (!optional && nonoptional_check (dim, n) == FAILURE)
352 return FAILURE;
353
354 return SUCCESS;
355 }
356
357
358 /* If a coarray DIM parameter is a constant, make sure that it is greater than
359 zero and less than or equal to the corank of the given array. */
360
361 static gfc_try
362 dim_corank_check (gfc_expr *dim, gfc_expr *array)
363 {
364 gfc_array_ref *ar;
365 int corank;
366
367 gcc_assert (array->expr_type == EXPR_VARIABLE);
368
369 if (dim->expr_type != EXPR_CONSTANT)
370 return SUCCESS;
371
372 ar = gfc_find_array_ref (array);
373 corank = ar->as->corank;
374
375 if (mpz_cmp_ui (dim->value.integer, 1) < 0
376 || mpz_cmp_ui (dim->value.integer, corank) > 0)
377 {
378 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
379 "codimension index", gfc_current_intrinsic, &dim->where);
380
381 return FAILURE;
382 }
383
384 return SUCCESS;
385 }
386
387
388 /* If a DIM parameter is a constant, make sure that it is greater than
389 zero and less than or equal to the rank of the given array. If
390 allow_assumed is zero then dim must be less than the rank of the array
391 for assumed size arrays. */
392
393 static gfc_try
394 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
395 {
396 gfc_array_ref *ar;
397 int rank;
398
399 if (dim == NULL)
400 return SUCCESS;
401
402 if (dim->expr_type != EXPR_CONSTANT
403 || (array->expr_type != EXPR_VARIABLE
404 && array->expr_type != EXPR_ARRAY))
405 return SUCCESS;
406
407 rank = array->rank;
408 if (array->expr_type == EXPR_VARIABLE)
409 {
410 ar = gfc_find_array_ref (array);
411 if (ar->as->type == AS_ASSUMED_SIZE
412 && !allow_assumed
413 && ar->type != AR_ELEMENT
414 && ar->type != AR_SECTION)
415 rank--;
416 }
417
418 if (mpz_cmp_ui (dim->value.integer, 1) < 0
419 || mpz_cmp_ui (dim->value.integer, rank) > 0)
420 {
421 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
422 "dimension index", gfc_current_intrinsic, &dim->where);
423
424 return FAILURE;
425 }
426
427 return SUCCESS;
428 }
429
430
431 /* Compare the size of a along dimension ai with the size of b along
432 dimension bi, returning 0 if they are known not to be identical,
433 and 1 if they are identical, or if this cannot be determined. */
434
435 static int
436 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
437 {
438 mpz_t a_size, b_size;
439 int ret;
440
441 gcc_assert (a->rank > ai);
442 gcc_assert (b->rank > bi);
443
444 ret = 1;
445
446 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
447 {
448 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
449 {
450 if (mpz_cmp (a_size, b_size) != 0)
451 ret = 0;
452
453 mpz_clear (b_size);
454 }
455 mpz_clear (a_size);
456 }
457 return ret;
458 }
459
460
461 /* Check whether two character expressions have the same length;
462 returns SUCCESS if they have or if the length cannot be determined. */
463
464 gfc_try
465 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
466 {
467 long len_a, len_b;
468 len_a = len_b = -1;
469
470 if (a->ts.u.cl && a->ts.u.cl->length
471 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
472 len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
473 else if (a->expr_type == EXPR_CONSTANT
474 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
475 len_a = a->value.character.length;
476 else
477 return SUCCESS;
478
479 if (b->ts.u.cl && b->ts.u.cl->length
480 && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
481 len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
482 else if (b->expr_type == EXPR_CONSTANT
483 && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
484 len_b = b->value.character.length;
485 else
486 return SUCCESS;
487
488 if (len_a == len_b)
489 return SUCCESS;
490
491 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
492 len_a, len_b, name, &a->where);
493 return FAILURE;
494 }
495
496
497 /***** Check functions *****/
498
499 /* Check subroutine suitable for intrinsics taking a real argument and
500 a kind argument for the result. */
501
502 static gfc_try
503 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
504 {
505 if (type_check (a, 0, BT_REAL) == FAILURE)
506 return FAILURE;
507 if (kind_check (kind, 1, type) == FAILURE)
508 return FAILURE;
509
510 return SUCCESS;
511 }
512
513
514 /* Check subroutine suitable for ceiling, floor and nint. */
515
516 gfc_try
517 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
518 {
519 return check_a_kind (a, kind, BT_INTEGER);
520 }
521
522
523 /* Check subroutine suitable for aint, anint. */
524
525 gfc_try
526 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
527 {
528 return check_a_kind (a, kind, BT_REAL);
529 }
530
531
532 gfc_try
533 gfc_check_abs (gfc_expr *a)
534 {
535 if (numeric_check (a, 0) == FAILURE)
536 return FAILURE;
537
538 return SUCCESS;
539 }
540
541
542 gfc_try
543 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
544 {
545 if (type_check (a, 0, BT_INTEGER) == FAILURE)
546 return FAILURE;
547 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
548 return FAILURE;
549
550 return SUCCESS;
551 }
552
553
554 gfc_try
555 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
556 {
557 if (type_check (name, 0, BT_CHARACTER) == FAILURE
558 || scalar_check (name, 0) == FAILURE)
559 return FAILURE;
560 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
561 return FAILURE;
562
563 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
564 || scalar_check (mode, 1) == FAILURE)
565 return FAILURE;
566 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
567 return FAILURE;
568
569 return SUCCESS;
570 }
571
572
573 gfc_try
574 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
575 {
576 if (logical_array_check (mask, 0) == FAILURE)
577 return FAILURE;
578
579 if (dim_check (dim, 1, false) == FAILURE)
580 return FAILURE;
581
582 if (dim_rank_check (dim, mask, 0) == FAILURE)
583 return FAILURE;
584
585 return SUCCESS;
586 }
587
588
589 gfc_try
590 gfc_check_allocated (gfc_expr *array)
591 {
592 symbol_attribute attr;
593
594 if (variable_check (array, 0) == FAILURE)
595 return FAILURE;
596
597 attr = gfc_variable_attr (array, NULL);
598 if (!attr.allocatable)
599 {
600 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
601 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
602 &array->where);
603 return FAILURE;
604 }
605
606 return SUCCESS;
607 }
608
609
610 /* Common check function where the first argument must be real or
611 integer and the second argument must be the same as the first. */
612
613 gfc_try
614 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
615 {
616 if (int_or_real_check (a, 0) == FAILURE)
617 return FAILURE;
618
619 if (a->ts.type != p->ts.type)
620 {
621 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
622 "have the same type", gfc_current_intrinsic_arg[0],
623 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
624 &p->where);
625 return FAILURE;
626 }
627
628 if (a->ts.kind != p->ts.kind)
629 {
630 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
631 &p->where) == FAILURE)
632 return FAILURE;
633 }
634
635 return SUCCESS;
636 }
637
638
639 gfc_try
640 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
641 {
642 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
643 return FAILURE;
644
645 return SUCCESS;
646 }
647
648
649 gfc_try
650 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
651 {
652 symbol_attribute attr1, attr2;
653 int i;
654 gfc_try t;
655 locus *where;
656
657 where = &pointer->where;
658
659 if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
660 attr1 = gfc_expr_attr (pointer);
661 else if (pointer->expr_type == EXPR_NULL)
662 goto null_arg;
663 else
664 gcc_assert (0); /* Pointer must be a variable or a function. */
665
666 if (!attr1.pointer && !attr1.proc_pointer)
667 {
668 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
669 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
670 &pointer->where);
671 return FAILURE;
672 }
673
674 /* Target argument is optional. */
675 if (target == NULL)
676 return SUCCESS;
677
678 where = &target->where;
679 if (target->expr_type == EXPR_NULL)
680 goto null_arg;
681
682 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
683 attr2 = gfc_expr_attr (target);
684 else
685 {
686 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
687 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
688 gfc_current_intrinsic, &target->where);
689 return FAILURE;
690 }
691
692 if (attr1.pointer && !attr2.pointer && !attr2.target)
693 {
694 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
695 "or a TARGET", gfc_current_intrinsic_arg[1],
696 gfc_current_intrinsic, &target->where);
697 return FAILURE;
698 }
699
700 t = SUCCESS;
701 if (same_type_check (pointer, 0, target, 1) == FAILURE)
702 t = FAILURE;
703 if (rank_check (target, 0, pointer->rank) == FAILURE)
704 t = FAILURE;
705 if (target->rank > 0)
706 {
707 for (i = 0; i < target->rank; i++)
708 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
709 {
710 gfc_error ("Array section with a vector subscript at %L shall not "
711 "be the target of a pointer",
712 &target->where);
713 t = FAILURE;
714 break;
715 }
716 }
717 return t;
718
719 null_arg:
720
721 gfc_error ("NULL pointer at %L is not permitted as actual argument "
722 "of '%s' intrinsic function", where, gfc_current_intrinsic);
723 return FAILURE;
724
725 }
726
727
728 gfc_try
729 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
730 {
731 /* gfc_notify_std would be a wast of time as the return value
732 is seemingly used only for the generic resolution. The error
733 will be: Too many arguments. */
734 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
735 return FAILURE;
736
737 return gfc_check_atan2 (y, x);
738 }
739
740
741 gfc_try
742 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
743 {
744 if (type_check (y, 0, BT_REAL) == FAILURE)
745 return FAILURE;
746 if (same_type_check (y, 0, x, 1) == FAILURE)
747 return FAILURE;
748
749 return SUCCESS;
750 }
751
752
753 /* BESJN and BESYN functions. */
754
755 gfc_try
756 gfc_check_besn (gfc_expr *n, gfc_expr *x)
757 {
758 if (type_check (n, 0, BT_INTEGER) == FAILURE)
759 return FAILURE;
760
761 if (type_check (x, 1, BT_REAL) == FAILURE)
762 return FAILURE;
763
764 return SUCCESS;
765 }
766
767
768 gfc_try
769 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
770 {
771 if (type_check (i, 0, BT_INTEGER) == FAILURE)
772 return FAILURE;
773 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
774 return FAILURE;
775
776 return SUCCESS;
777 }
778
779
780 gfc_try
781 gfc_check_char (gfc_expr *i, gfc_expr *kind)
782 {
783 if (type_check (i, 0, BT_INTEGER) == FAILURE)
784 return FAILURE;
785 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
786 return FAILURE;
787
788 return SUCCESS;
789 }
790
791
792 gfc_try
793 gfc_check_chdir (gfc_expr *dir)
794 {
795 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
796 return FAILURE;
797 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
798 return FAILURE;
799
800 return SUCCESS;
801 }
802
803
804 gfc_try
805 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
806 {
807 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
808 return FAILURE;
809 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
810 return FAILURE;
811
812 if (status == NULL)
813 return SUCCESS;
814
815 if (type_check (status, 1, BT_INTEGER) == FAILURE)
816 return FAILURE;
817 if (scalar_check (status, 1) == FAILURE)
818 return FAILURE;
819
820 return SUCCESS;
821 }
822
823
824 gfc_try
825 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
826 {
827 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
828 return FAILURE;
829 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
830 return FAILURE;
831
832 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
833 return FAILURE;
834 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
835 return FAILURE;
836
837 return SUCCESS;
838 }
839
840
841 gfc_try
842 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
843 {
844 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
845 return FAILURE;
846 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
847 return FAILURE;
848
849 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
850 return FAILURE;
851 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
852 return FAILURE;
853
854 if (status == NULL)
855 return SUCCESS;
856
857 if (type_check (status, 2, BT_INTEGER) == FAILURE)
858 return FAILURE;
859
860 if (scalar_check (status, 2) == FAILURE)
861 return FAILURE;
862
863 return SUCCESS;
864 }
865
866
867 gfc_try
868 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
869 {
870 if (numeric_check (x, 0) == FAILURE)
871 return FAILURE;
872
873 if (y != NULL)
874 {
875 if (numeric_check (y, 1) == FAILURE)
876 return FAILURE;
877
878 if (x->ts.type == BT_COMPLEX)
879 {
880 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
881 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
882 gfc_current_intrinsic, &y->where);
883 return FAILURE;
884 }
885
886 if (y->ts.type == BT_COMPLEX)
887 {
888 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
889 "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
890 gfc_current_intrinsic, &y->where);
891 return FAILURE;
892 }
893
894 }
895
896 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
897 return FAILURE;
898
899 return SUCCESS;
900 }
901
902
903 gfc_try
904 gfc_check_complex (gfc_expr *x, gfc_expr *y)
905 {
906 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
907 {
908 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
909 "or REAL", gfc_current_intrinsic_arg[0],
910 gfc_current_intrinsic, &x->where);
911 return FAILURE;
912 }
913 if (scalar_check (x, 0) == FAILURE)
914 return FAILURE;
915
916 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
917 {
918 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
919 "or REAL", gfc_current_intrinsic_arg[1],
920 gfc_current_intrinsic, &y->where);
921 return FAILURE;
922 }
923 if (scalar_check (y, 1) == FAILURE)
924 return FAILURE;
925
926 return SUCCESS;
927 }
928
929
930 gfc_try
931 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
932 {
933 if (logical_array_check (mask, 0) == FAILURE)
934 return FAILURE;
935 if (dim_check (dim, 1, false) == FAILURE)
936 return FAILURE;
937 if (dim_rank_check (dim, mask, 0) == FAILURE)
938 return FAILURE;
939 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
940 return FAILURE;
941 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
942 "with KIND argument at %L",
943 gfc_current_intrinsic, &kind->where) == FAILURE)
944 return FAILURE;
945
946 return SUCCESS;
947 }
948
949
950 gfc_try
951 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
952 {
953 if (array_check (array, 0) == FAILURE)
954 return FAILURE;
955
956 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
957 return FAILURE;
958
959 if (dim_check (dim, 2, true) == FAILURE)
960 return FAILURE;
961
962 if (dim_rank_check (dim, array, false) == FAILURE)
963 return FAILURE;
964
965 if (array->rank == 1 || shift->rank == 0)
966 {
967 if (scalar_check (shift, 1) == FAILURE)
968 return FAILURE;
969 }
970 else if (shift->rank == array->rank - 1)
971 {
972 int d;
973 if (!dim)
974 d = 1;
975 else if (dim->expr_type == EXPR_CONSTANT)
976 gfc_extract_int (dim, &d);
977 else
978 d = -1;
979
980 if (d > 0)
981 {
982 int i, j;
983 for (i = 0, j = 0; i < array->rank; i++)
984 if (i != d - 1)
985 {
986 if (!identical_dimen_shape (array, i, shift, j))
987 {
988 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
989 "invalid shape in dimension %d (%ld/%ld)",
990 gfc_current_intrinsic_arg[1],
991 gfc_current_intrinsic, &shift->where, i + 1,
992 mpz_get_si (array->shape[i]),
993 mpz_get_si (shift->shape[j]));
994 return FAILURE;
995 }
996
997 j += 1;
998 }
999 }
1000 }
1001 else
1002 {
1003 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1004 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1005 gfc_current_intrinsic, &shift->where, array->rank - 1);
1006 return FAILURE;
1007 }
1008
1009 return SUCCESS;
1010 }
1011
1012
1013 gfc_try
1014 gfc_check_ctime (gfc_expr *time)
1015 {
1016 if (scalar_check (time, 0) == FAILURE)
1017 return FAILURE;
1018
1019 if (type_check (time, 0, BT_INTEGER) == FAILURE)
1020 return FAILURE;
1021
1022 return SUCCESS;
1023 }
1024
1025
1026 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1027 {
1028 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1029 return FAILURE;
1030
1031 return SUCCESS;
1032 }
1033
1034 gfc_try
1035 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1036 {
1037 if (numeric_check (x, 0) == FAILURE)
1038 return FAILURE;
1039
1040 if (y != NULL)
1041 {
1042 if (numeric_check (y, 1) == FAILURE)
1043 return FAILURE;
1044
1045 if (x->ts.type == BT_COMPLEX)
1046 {
1047 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1048 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
1049 gfc_current_intrinsic, &y->where);
1050 return FAILURE;
1051 }
1052
1053 if (y->ts.type == BT_COMPLEX)
1054 {
1055 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1056 "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
1057 gfc_current_intrinsic, &y->where);
1058 return FAILURE;
1059 }
1060 }
1061
1062 return SUCCESS;
1063 }
1064
1065
1066 gfc_try
1067 gfc_check_dble (gfc_expr *x)
1068 {
1069 if (numeric_check (x, 0) == FAILURE)
1070 return FAILURE;
1071
1072 return SUCCESS;
1073 }
1074
1075
1076 gfc_try
1077 gfc_check_digits (gfc_expr *x)
1078 {
1079 if (int_or_real_check (x, 0) == FAILURE)
1080 return FAILURE;
1081
1082 return SUCCESS;
1083 }
1084
1085
1086 gfc_try
1087 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1088 {
1089 switch (vector_a->ts.type)
1090 {
1091 case BT_LOGICAL:
1092 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1093 return FAILURE;
1094 break;
1095
1096 case BT_INTEGER:
1097 case BT_REAL:
1098 case BT_COMPLEX:
1099 if (numeric_check (vector_b, 1) == FAILURE)
1100 return FAILURE;
1101 break;
1102
1103 default:
1104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1105 "or LOGICAL", gfc_current_intrinsic_arg[0],
1106 gfc_current_intrinsic, &vector_a->where);
1107 return FAILURE;
1108 }
1109
1110 if (rank_check (vector_a, 0, 1) == FAILURE)
1111 return FAILURE;
1112
1113 if (rank_check (vector_b, 1, 1) == FAILURE)
1114 return FAILURE;
1115
1116 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1117 {
1118 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1119 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
1120 gfc_current_intrinsic_arg[1], &vector_a->where);
1121 return FAILURE;
1122 }
1123
1124 return SUCCESS;
1125 }
1126
1127
1128 gfc_try
1129 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1130 {
1131 if (type_check (x, 0, BT_REAL) == FAILURE
1132 || type_check (y, 1, BT_REAL) == FAILURE)
1133 return FAILURE;
1134
1135 if (x->ts.kind != gfc_default_real_kind)
1136 {
1137 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1138 "real", gfc_current_intrinsic_arg[0],
1139 gfc_current_intrinsic, &x->where);
1140 return FAILURE;
1141 }
1142
1143 if (y->ts.kind != gfc_default_real_kind)
1144 {
1145 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1146 "real", gfc_current_intrinsic_arg[1],
1147 gfc_current_intrinsic, &y->where);
1148 return FAILURE;
1149 }
1150
1151 return SUCCESS;
1152 }
1153
1154
1155 gfc_try
1156 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1157 gfc_expr *dim)
1158 {
1159 if (array_check (array, 0) == FAILURE)
1160 return FAILURE;
1161
1162 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1163 return FAILURE;
1164
1165 if (dim_check (dim, 3, true) == FAILURE)
1166 return FAILURE;
1167
1168 if (dim_rank_check (dim, array, false) == FAILURE)
1169 return FAILURE;
1170
1171 if (array->rank == 1 || shift->rank == 0)
1172 {
1173 if (scalar_check (shift, 1) == FAILURE)
1174 return FAILURE;
1175 }
1176 else if (shift->rank == array->rank - 1)
1177 {
1178 int d;
1179 if (!dim)
1180 d = 1;
1181 else if (dim->expr_type == EXPR_CONSTANT)
1182 gfc_extract_int (dim, &d);
1183 else
1184 d = -1;
1185
1186 if (d > 0)
1187 {
1188 int i, j;
1189 for (i = 0, j = 0; i < array->rank; i++)
1190 if (i != d - 1)
1191 {
1192 if (!identical_dimen_shape (array, i, shift, j))
1193 {
1194 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1195 "invalid shape in dimension %d (%ld/%ld)",
1196 gfc_current_intrinsic_arg[1],
1197 gfc_current_intrinsic, &shift->where, i + 1,
1198 mpz_get_si (array->shape[i]),
1199 mpz_get_si (shift->shape[j]));
1200 return FAILURE;
1201 }
1202
1203 j += 1;
1204 }
1205 }
1206 }
1207 else
1208 {
1209 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1210 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1211 gfc_current_intrinsic, &shift->where, array->rank - 1);
1212 return FAILURE;
1213 }
1214
1215 if (boundary != NULL)
1216 {
1217 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1218 return FAILURE;
1219
1220 if (array->rank == 1 || boundary->rank == 0)
1221 {
1222 if (scalar_check (boundary, 2) == FAILURE)
1223 return FAILURE;
1224 }
1225 else if (boundary->rank == array->rank - 1)
1226 {
1227 if (gfc_check_conformance (shift, boundary,
1228 "arguments '%s' and '%s' for "
1229 "intrinsic %s",
1230 gfc_current_intrinsic_arg[1],
1231 gfc_current_intrinsic_arg[2],
1232 gfc_current_intrinsic ) == FAILURE)
1233 return FAILURE;
1234 }
1235 else
1236 {
1237 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1238 "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
1239 gfc_current_intrinsic, &shift->where, array->rank - 1);
1240 return FAILURE;
1241 }
1242 }
1243
1244 return SUCCESS;
1245 }
1246
1247
1248 /* A single complex argument. */
1249
1250 gfc_try
1251 gfc_check_fn_c (gfc_expr *a)
1252 {
1253 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1254 return FAILURE;
1255
1256 return SUCCESS;
1257 }
1258
1259
1260 /* A single real argument. */
1261
1262 gfc_try
1263 gfc_check_fn_r (gfc_expr *a)
1264 {
1265 if (type_check (a, 0, BT_REAL) == FAILURE)
1266 return FAILURE;
1267
1268 return SUCCESS;
1269 }
1270
1271 /* A single double argument. */
1272
1273 gfc_try
1274 gfc_check_fn_d (gfc_expr *a)
1275 {
1276 if (double_check (a, 0) == FAILURE)
1277 return FAILURE;
1278
1279 return SUCCESS;
1280 }
1281
1282 /* A single real or complex argument. */
1283
1284 gfc_try
1285 gfc_check_fn_rc (gfc_expr *a)
1286 {
1287 if (real_or_complex_check (a, 0) == FAILURE)
1288 return FAILURE;
1289
1290 return SUCCESS;
1291 }
1292
1293
1294 gfc_try
1295 gfc_check_fn_rc2008 (gfc_expr *a)
1296 {
1297 if (real_or_complex_check (a, 0) == FAILURE)
1298 return FAILURE;
1299
1300 if (a->ts.type == BT_COMPLEX
1301 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1302 "argument of '%s' intrinsic at %L",
1303 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1304 &a->where) == FAILURE)
1305 return FAILURE;
1306
1307 return SUCCESS;
1308 }
1309
1310
1311 gfc_try
1312 gfc_check_fnum (gfc_expr *unit)
1313 {
1314 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1315 return FAILURE;
1316
1317 if (scalar_check (unit, 0) == FAILURE)
1318 return FAILURE;
1319
1320 return SUCCESS;
1321 }
1322
1323
1324 gfc_try
1325 gfc_check_huge (gfc_expr *x)
1326 {
1327 if (int_or_real_check (x, 0) == FAILURE)
1328 return FAILURE;
1329
1330 return SUCCESS;
1331 }
1332
1333
1334 gfc_try
1335 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1336 {
1337 if (type_check (x, 0, BT_REAL) == FAILURE)
1338 return FAILURE;
1339 if (same_type_check (x, 0, y, 1) == FAILURE)
1340 return FAILURE;
1341
1342 return SUCCESS;
1343 }
1344
1345
1346 /* Check that the single argument is an integer. */
1347
1348 gfc_try
1349 gfc_check_i (gfc_expr *i)
1350 {
1351 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1352 return FAILURE;
1353
1354 return SUCCESS;
1355 }
1356
1357
1358 gfc_try
1359 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1360 {
1361 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1362 return FAILURE;
1363
1364 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1365 return FAILURE;
1366
1367 if (i->ts.kind != j->ts.kind)
1368 {
1369 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1370 &i->where) == FAILURE)
1371 return FAILURE;
1372 }
1373
1374 return SUCCESS;
1375 }
1376
1377
1378 gfc_try
1379 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1380 {
1381 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1382 return FAILURE;
1383
1384 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1385 return FAILURE;
1386
1387 return SUCCESS;
1388 }
1389
1390
1391 gfc_try
1392 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1393 {
1394 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1395 return FAILURE;
1396
1397 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1398 return FAILURE;
1399
1400 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1401 return FAILURE;
1402
1403 return SUCCESS;
1404 }
1405
1406
1407 gfc_try
1408 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1409 {
1410 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1411 return FAILURE;
1412
1413 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1414 return FAILURE;
1415
1416 return SUCCESS;
1417 }
1418
1419
1420 gfc_try
1421 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1422 {
1423 int i;
1424
1425 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1426 return FAILURE;
1427
1428 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1429 return FAILURE;
1430
1431 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1432 "with KIND argument at %L",
1433 gfc_current_intrinsic, &kind->where) == FAILURE)
1434 return FAILURE;
1435
1436 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1437 {
1438 gfc_expr *start;
1439 gfc_expr *end;
1440 gfc_ref *ref;
1441
1442 /* Substring references don't have the charlength set. */
1443 ref = c->ref;
1444 while (ref && ref->type != REF_SUBSTRING)
1445 ref = ref->next;
1446
1447 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1448
1449 if (!ref)
1450 {
1451 /* Check that the argument is length one. Non-constant lengths
1452 can't be checked here, so assume they are ok. */
1453 if (c->ts.u.cl && c->ts.u.cl->length)
1454 {
1455 /* If we already have a length for this expression then use it. */
1456 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1457 return SUCCESS;
1458 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1459 }
1460 else
1461 return SUCCESS;
1462 }
1463 else
1464 {
1465 start = ref->u.ss.start;
1466 end = ref->u.ss.end;
1467
1468 gcc_assert (start);
1469 if (end == NULL || end->expr_type != EXPR_CONSTANT
1470 || start->expr_type != EXPR_CONSTANT)
1471 return SUCCESS;
1472
1473 i = mpz_get_si (end->value.integer) + 1
1474 - mpz_get_si (start->value.integer);
1475 }
1476 }
1477 else
1478 return SUCCESS;
1479
1480 if (i != 1)
1481 {
1482 gfc_error ("Argument of %s at %L must be of length one",
1483 gfc_current_intrinsic, &c->where);
1484 return FAILURE;
1485 }
1486
1487 return SUCCESS;
1488 }
1489
1490
1491 gfc_try
1492 gfc_check_idnint (gfc_expr *a)
1493 {
1494 if (double_check (a, 0) == FAILURE)
1495 return FAILURE;
1496
1497 return SUCCESS;
1498 }
1499
1500
1501 gfc_try
1502 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1503 {
1504 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1505 return FAILURE;
1506
1507 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1508 return FAILURE;
1509
1510 if (i->ts.kind != j->ts.kind)
1511 {
1512 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1513 &i->where) == FAILURE)
1514 return FAILURE;
1515 }
1516
1517 return SUCCESS;
1518 }
1519
1520
1521 gfc_try
1522 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1523 gfc_expr *kind)
1524 {
1525 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1526 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1527 return FAILURE;
1528
1529 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1530 return FAILURE;
1531
1532 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1533 return FAILURE;
1534 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1535 "with KIND argument at %L",
1536 gfc_current_intrinsic, &kind->where) == FAILURE)
1537 return FAILURE;
1538
1539 if (string->ts.kind != substring->ts.kind)
1540 {
1541 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1542 "kind as '%s'", gfc_current_intrinsic_arg[1],
1543 gfc_current_intrinsic, &substring->where,
1544 gfc_current_intrinsic_arg[0]);
1545 return FAILURE;
1546 }
1547
1548 return SUCCESS;
1549 }
1550
1551
1552 gfc_try
1553 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1554 {
1555 if (numeric_check (x, 0) == FAILURE)
1556 return FAILURE;
1557
1558 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1559 return FAILURE;
1560
1561 return SUCCESS;
1562 }
1563
1564
1565 gfc_try
1566 gfc_check_intconv (gfc_expr *x)
1567 {
1568 if (numeric_check (x, 0) == FAILURE)
1569 return FAILURE;
1570
1571 return SUCCESS;
1572 }
1573
1574
1575 gfc_try
1576 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1577 {
1578 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1579 return FAILURE;
1580
1581 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1582 return FAILURE;
1583
1584 if (i->ts.kind != j->ts.kind)
1585 {
1586 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1587 &i->where) == FAILURE)
1588 return FAILURE;
1589 }
1590
1591 return SUCCESS;
1592 }
1593
1594
1595 gfc_try
1596 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1597 {
1598 if (type_check (i, 0, BT_INTEGER) == FAILURE
1599 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1600 return FAILURE;
1601
1602 return SUCCESS;
1603 }
1604
1605
1606 gfc_try
1607 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1608 {
1609 if (type_check (i, 0, BT_INTEGER) == FAILURE
1610 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1611 return FAILURE;
1612
1613 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1614 return FAILURE;
1615
1616 return SUCCESS;
1617 }
1618
1619
1620 gfc_try
1621 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1622 {
1623 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1624 return FAILURE;
1625
1626 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1627 return FAILURE;
1628
1629 return SUCCESS;
1630 }
1631
1632
1633 gfc_try
1634 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1635 {
1636 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1637 return FAILURE;
1638
1639 if (scalar_check (pid, 0) == FAILURE)
1640 return FAILURE;
1641
1642 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1643 return FAILURE;
1644
1645 if (scalar_check (sig, 1) == FAILURE)
1646 return FAILURE;
1647
1648 if (status == NULL)
1649 return SUCCESS;
1650
1651 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1652 return FAILURE;
1653
1654 if (scalar_check (status, 2) == FAILURE)
1655 return FAILURE;
1656
1657 return SUCCESS;
1658 }
1659
1660
1661 gfc_try
1662 gfc_check_kind (gfc_expr *x)
1663 {
1664 if (x->ts.type == BT_DERIVED)
1665 {
1666 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1667 "non-derived type", gfc_current_intrinsic_arg[0],
1668 gfc_current_intrinsic, &x->where);
1669 return FAILURE;
1670 }
1671
1672 return SUCCESS;
1673 }
1674
1675
1676 gfc_try
1677 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1678 {
1679 if (array_check (array, 0) == FAILURE)
1680 return FAILURE;
1681
1682 if (dim_check (dim, 1, false) == FAILURE)
1683 return FAILURE;
1684
1685 if (dim_rank_check (dim, array, 1) == FAILURE)
1686 return FAILURE;
1687
1688 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1689 return FAILURE;
1690 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1691 "with KIND argument at %L",
1692 gfc_current_intrinsic, &kind->where) == FAILURE)
1693 return FAILURE;
1694
1695 return SUCCESS;
1696 }
1697
1698
1699 gfc_try
1700 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
1701 {
1702 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1703 {
1704 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1705 return FAILURE;
1706 }
1707
1708 if (!is_coarray (coarray))
1709 {
1710 gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND "
1711 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
1712 return FAILURE;
1713 }
1714
1715 if (dim != NULL)
1716 {
1717 if (dim_check (dim, 1, false) == FAILURE)
1718 return FAILURE;
1719
1720 if (dim_corank_check (dim, coarray) == FAILURE)
1721 return FAILURE;
1722 }
1723
1724 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1725 return FAILURE;
1726
1727 return SUCCESS;
1728 }
1729
1730
1731 gfc_try
1732 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1733 {
1734 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1735 return FAILURE;
1736
1737 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1738 return FAILURE;
1739 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1740 "with KIND argument at %L",
1741 gfc_current_intrinsic, &kind->where) == FAILURE)
1742 return FAILURE;
1743
1744 return SUCCESS;
1745 }
1746
1747
1748 gfc_try
1749 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
1750 {
1751 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1752 return FAILURE;
1753 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
1754 return FAILURE;
1755
1756 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
1757 return FAILURE;
1758 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
1759 return FAILURE;
1760
1761 return SUCCESS;
1762 }
1763
1764
1765 gfc_try
1766 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1767 {
1768 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1769 return FAILURE;
1770 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1771 return FAILURE;
1772
1773 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1774 return FAILURE;
1775 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1776 return FAILURE;
1777
1778 return SUCCESS;
1779 }
1780
1781
1782 gfc_try
1783 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1784 {
1785 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1786 return FAILURE;
1787 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1788 return FAILURE;
1789
1790 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1791 return FAILURE;
1792 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
1793 return FAILURE;
1794
1795 if (status == NULL)
1796 return SUCCESS;
1797
1798 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1799 return FAILURE;
1800
1801 if (scalar_check (status, 2) == FAILURE)
1802 return FAILURE;
1803
1804 return SUCCESS;
1805 }
1806
1807
1808 gfc_try
1809 gfc_check_loc (gfc_expr *expr)
1810 {
1811 return variable_check (expr, 0);
1812 }
1813
1814
1815 gfc_try
1816 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1817 {
1818 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1819 return FAILURE;
1820 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1821 return FAILURE;
1822
1823 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1824 return FAILURE;
1825 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1826 return FAILURE;
1827
1828 return SUCCESS;
1829 }
1830
1831
1832 gfc_try
1833 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1834 {
1835 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1836 return FAILURE;
1837 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1838 return FAILURE;
1839
1840 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1841 return FAILURE;
1842 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1843 return FAILURE;
1844
1845 if (status == NULL)
1846 return SUCCESS;
1847
1848 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1849 return FAILURE;
1850
1851 if (scalar_check (status, 2) == FAILURE)
1852 return FAILURE;
1853
1854 return SUCCESS;
1855 }
1856
1857
1858 gfc_try
1859 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1860 {
1861 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1862 return FAILURE;
1863 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1864 return FAILURE;
1865
1866 return SUCCESS;
1867 }
1868
1869
1870 /* Min/max family. */
1871
1872 static gfc_try
1873 min_max_args (gfc_actual_arglist *arg)
1874 {
1875 if (arg == NULL || arg->next == NULL)
1876 {
1877 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1878 gfc_current_intrinsic, gfc_current_intrinsic_where);
1879 return FAILURE;
1880 }
1881
1882 return SUCCESS;
1883 }
1884
1885
1886 static gfc_try
1887 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1888 {
1889 gfc_actual_arglist *arg, *tmp;
1890
1891 gfc_expr *x;
1892 int m, n;
1893
1894 if (min_max_args (arglist) == FAILURE)
1895 return FAILURE;
1896
1897 for (arg = arglist, n=1; arg; arg = arg->next, n++)
1898 {
1899 x = arg->expr;
1900 if (x->ts.type != type || x->ts.kind != kind)
1901 {
1902 if (x->ts.type == type)
1903 {
1904 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1905 "kinds at %L", &x->where) == FAILURE)
1906 return FAILURE;
1907 }
1908 else
1909 {
1910 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1911 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1912 gfc_basic_typename (type), kind);
1913 return FAILURE;
1914 }
1915 }
1916
1917 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1918 if (gfc_check_conformance (tmp->expr, x,
1919 "arguments 'a%d' and 'a%d' for "
1920 "intrinsic '%s'", m, n,
1921 gfc_current_intrinsic) == FAILURE)
1922 return FAILURE;
1923 }
1924
1925 return SUCCESS;
1926 }
1927
1928
1929 gfc_try
1930 gfc_check_min_max (gfc_actual_arglist *arg)
1931 {
1932 gfc_expr *x;
1933
1934 if (min_max_args (arg) == FAILURE)
1935 return FAILURE;
1936
1937 x = arg->expr;
1938
1939 if (x->ts.type == BT_CHARACTER)
1940 {
1941 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1942 "with CHARACTER argument at %L",
1943 gfc_current_intrinsic, &x->where) == FAILURE)
1944 return FAILURE;
1945 }
1946 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1947 {
1948 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1949 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1950 return FAILURE;
1951 }
1952
1953 return check_rest (x->ts.type, x->ts.kind, arg);
1954 }
1955
1956
1957 gfc_try
1958 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1959 {
1960 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1961 }
1962
1963
1964 gfc_try
1965 gfc_check_min_max_real (gfc_actual_arglist *arg)
1966 {
1967 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1968 }
1969
1970
1971 gfc_try
1972 gfc_check_min_max_double (gfc_actual_arglist *arg)
1973 {
1974 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1975 }
1976
1977
1978 /* End of min/max family. */
1979
1980 gfc_try
1981 gfc_check_malloc (gfc_expr *size)
1982 {
1983 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1984 return FAILURE;
1985
1986 if (scalar_check (size, 0) == FAILURE)
1987 return FAILURE;
1988
1989 return SUCCESS;
1990 }
1991
1992
1993 gfc_try
1994 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1995 {
1996 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1997 {
1998 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1999 "or LOGICAL", gfc_current_intrinsic_arg[0],
2000 gfc_current_intrinsic, &matrix_a->where);
2001 return FAILURE;
2002 }
2003
2004 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2005 {
2006 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2007 "or LOGICAL", gfc_current_intrinsic_arg[1],
2008 gfc_current_intrinsic, &matrix_b->where);
2009 return FAILURE;
2010 }
2011
2012 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2013 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2014 {
2015 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2016 gfc_current_intrinsic, &matrix_a->where,
2017 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2018 return FAILURE;
2019 }
2020
2021 switch (matrix_a->rank)
2022 {
2023 case 1:
2024 if (rank_check (matrix_b, 1, 2) == FAILURE)
2025 return FAILURE;
2026 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2027 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2028 {
2029 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2030 "and '%s' at %L for intrinsic matmul",
2031 gfc_current_intrinsic_arg[0],
2032 gfc_current_intrinsic_arg[1], &matrix_a->where);
2033 return FAILURE;
2034 }
2035 break;
2036
2037 case 2:
2038 if (matrix_b->rank != 2)
2039 {
2040 if (rank_check (matrix_b, 1, 1) == FAILURE)
2041 return FAILURE;
2042 }
2043 /* matrix_b has rank 1 or 2 here. Common check for the cases
2044 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2045 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2046 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2047 {
2048 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2049 "dimension 1 for argument '%s' at %L for intrinsic "
2050 "matmul", gfc_current_intrinsic_arg[0],
2051 gfc_current_intrinsic_arg[1], &matrix_a->where);
2052 return FAILURE;
2053 }
2054 break;
2055
2056 default:
2057 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2058 "1 or 2", gfc_current_intrinsic_arg[0],
2059 gfc_current_intrinsic, &matrix_a->where);
2060 return FAILURE;
2061 }
2062
2063 return SUCCESS;
2064 }
2065
2066
2067 /* Whoever came up with this interface was probably on something.
2068 The possibilities for the occupation of the second and third
2069 parameters are:
2070
2071 Arg #2 Arg #3
2072 NULL NULL
2073 DIM NULL
2074 MASK NULL
2075 NULL MASK minloc(array, mask=m)
2076 DIM MASK
2077
2078 I.e. in the case of minloc(array,mask), mask will be in the second
2079 position of the argument list and we'll have to fix that up. */
2080
2081 gfc_try
2082 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2083 {
2084 gfc_expr *a, *m, *d;
2085
2086 a = ap->expr;
2087 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2088 return FAILURE;
2089
2090 d = ap->next->expr;
2091 m = ap->next->next->expr;
2092
2093 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2094 && ap->next->name == NULL)
2095 {
2096 m = d;
2097 d = NULL;
2098 ap->next->expr = NULL;
2099 ap->next->next->expr = m;
2100 }
2101
2102 if (dim_check (d, 1, false) == FAILURE)
2103 return FAILURE;
2104
2105 if (dim_rank_check (d, a, 0) == FAILURE)
2106 return FAILURE;
2107
2108 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2109 return FAILURE;
2110
2111 if (m != NULL
2112 && gfc_check_conformance (a, m,
2113 "arguments '%s' and '%s' for intrinsic %s",
2114 gfc_current_intrinsic_arg[0],
2115 gfc_current_intrinsic_arg[2],
2116 gfc_current_intrinsic ) == FAILURE)
2117 return FAILURE;
2118
2119 return SUCCESS;
2120 }
2121
2122
2123 /* Similar to minloc/maxloc, the argument list might need to be
2124 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2125 difference is that MINLOC/MAXLOC take an additional KIND argument.
2126 The possibilities are:
2127
2128 Arg #2 Arg #3
2129 NULL NULL
2130 DIM NULL
2131 MASK NULL
2132 NULL MASK minval(array, mask=m)
2133 DIM MASK
2134
2135 I.e. in the case of minval(array,mask), mask will be in the second
2136 position of the argument list and we'll have to fix that up. */
2137
2138 static gfc_try
2139 check_reduction (gfc_actual_arglist *ap)
2140 {
2141 gfc_expr *a, *m, *d;
2142
2143 a = ap->expr;
2144 d = ap->next->expr;
2145 m = ap->next->next->expr;
2146
2147 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2148 && ap->next->name == NULL)
2149 {
2150 m = d;
2151 d = NULL;
2152 ap->next->expr = NULL;
2153 ap->next->next->expr = m;
2154 }
2155
2156 if (dim_check (d, 1, false) == FAILURE)
2157 return FAILURE;
2158
2159 if (dim_rank_check (d, a, 0) == FAILURE)
2160 return FAILURE;
2161
2162 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2163 return FAILURE;
2164
2165 if (m != NULL
2166 && gfc_check_conformance (a, m,
2167 "arguments '%s' and '%s' for intrinsic %s",
2168 gfc_current_intrinsic_arg[0],
2169 gfc_current_intrinsic_arg[2],
2170 gfc_current_intrinsic) == FAILURE)
2171 return FAILURE;
2172
2173 return SUCCESS;
2174 }
2175
2176
2177 gfc_try
2178 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2179 {
2180 if (int_or_real_check (ap->expr, 0) == FAILURE
2181 || array_check (ap->expr, 0) == FAILURE)
2182 return FAILURE;
2183
2184 return check_reduction (ap);
2185 }
2186
2187
2188 gfc_try
2189 gfc_check_product_sum (gfc_actual_arglist *ap)
2190 {
2191 if (numeric_check (ap->expr, 0) == FAILURE
2192 || array_check (ap->expr, 0) == FAILURE)
2193 return FAILURE;
2194
2195 return check_reduction (ap);
2196 }
2197
2198
2199 gfc_try
2200 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2201 {
2202 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2203 return FAILURE;
2204
2205 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2206 return FAILURE;
2207
2208 if (tsource->ts.type == BT_CHARACTER)
2209 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2210
2211 return SUCCESS;
2212 }
2213
2214
2215 gfc_try
2216 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2217 {
2218 symbol_attribute attr;
2219
2220 if (variable_check (from, 0) == FAILURE)
2221 return FAILURE;
2222
2223 attr = gfc_variable_attr (from, NULL);
2224 if (!attr.allocatable)
2225 {
2226 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2227 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2228 &from->where);
2229 return FAILURE;
2230 }
2231
2232 if (variable_check (to, 0) == FAILURE)
2233 return FAILURE;
2234
2235 attr = gfc_variable_attr (to, NULL);
2236 if (!attr.allocatable)
2237 {
2238 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2239 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2240 &to->where);
2241 return FAILURE;
2242 }
2243
2244 if (same_type_check (to, 1, from, 0) == FAILURE)
2245 return FAILURE;
2246
2247 if (to->rank != from->rank)
2248 {
2249 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2250 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
2251 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2252 &to->where, from->rank, to->rank);
2253 return FAILURE;
2254 }
2255
2256 if (to->ts.kind != from->ts.kind)
2257 {
2258 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2259 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
2260 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2261 &to->where, from->ts.kind, to->ts.kind);
2262 return FAILURE;
2263 }
2264
2265 return SUCCESS;
2266 }
2267
2268
2269 gfc_try
2270 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2271 {
2272 if (type_check (x, 0, BT_REAL) == FAILURE)
2273 return FAILURE;
2274
2275 if (type_check (s, 1, BT_REAL) == FAILURE)
2276 return FAILURE;
2277
2278 return SUCCESS;
2279 }
2280
2281
2282 gfc_try
2283 gfc_check_new_line (gfc_expr *a)
2284 {
2285 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2286 return FAILURE;
2287
2288 return SUCCESS;
2289 }
2290
2291
2292 gfc_try
2293 gfc_check_null (gfc_expr *mold)
2294 {
2295 symbol_attribute attr;
2296
2297 if (mold == NULL)
2298 return SUCCESS;
2299
2300 if (variable_check (mold, 0) == FAILURE)
2301 return FAILURE;
2302
2303 attr = gfc_variable_attr (mold, NULL);
2304
2305 if (!attr.pointer && !attr.proc_pointer)
2306 {
2307 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2308 gfc_current_intrinsic_arg[0],
2309 gfc_current_intrinsic, &mold->where);
2310 return FAILURE;
2311 }
2312
2313 return SUCCESS;
2314 }
2315
2316
2317 gfc_try
2318 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2319 {
2320 if (array_check (array, 0) == FAILURE)
2321 return FAILURE;
2322
2323 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2324 return FAILURE;
2325
2326 if (gfc_check_conformance (array, mask,
2327 "arguments '%s' and '%s' for intrinsic '%s'",
2328 gfc_current_intrinsic_arg[0],
2329 gfc_current_intrinsic_arg[1],
2330 gfc_current_intrinsic) == FAILURE)
2331 return FAILURE;
2332
2333 if (vector != NULL)
2334 {
2335 mpz_t array_size, vector_size;
2336 bool have_array_size, have_vector_size;
2337
2338 if (same_type_check (array, 0, vector, 2) == FAILURE)
2339 return FAILURE;
2340
2341 if (rank_check (vector, 2, 1) == FAILURE)
2342 return FAILURE;
2343
2344 /* VECTOR requires at least as many elements as MASK
2345 has .TRUE. values. */
2346 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2347 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2348
2349 if (have_vector_size
2350 && (mask->expr_type == EXPR_ARRAY
2351 || (mask->expr_type == EXPR_CONSTANT
2352 && have_array_size)))
2353 {
2354 int mask_true_values = 0;
2355
2356 if (mask->expr_type == EXPR_ARRAY)
2357 {
2358 gfc_constructor *mask_ctor;
2359 mask_ctor = gfc_constructor_first (mask->value.constructor);
2360 while (mask_ctor)
2361 {
2362 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2363 {
2364 mask_true_values = 0;
2365 break;
2366 }
2367
2368 if (mask_ctor->expr->value.logical)
2369 mask_true_values++;
2370
2371 mask_ctor = gfc_constructor_next (mask_ctor);
2372 }
2373 }
2374 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2375 mask_true_values = mpz_get_si (array_size);
2376
2377 if (mpz_get_si (vector_size) < mask_true_values)
2378 {
2379 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2380 "provide at least as many elements as there "
2381 "are .TRUE. values in '%s' (%ld/%d)",
2382 gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
2383 &vector->where, gfc_current_intrinsic_arg[1],
2384 mpz_get_si (vector_size), mask_true_values);
2385 return FAILURE;
2386 }
2387 }
2388
2389 if (have_array_size)
2390 mpz_clear (array_size);
2391 if (have_vector_size)
2392 mpz_clear (vector_size);
2393 }
2394
2395 return SUCCESS;
2396 }
2397
2398
2399 gfc_try
2400 gfc_check_precision (gfc_expr *x)
2401 {
2402 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2403 {
2404 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2405 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2406 gfc_current_intrinsic, &x->where);
2407 return FAILURE;
2408 }
2409
2410 return SUCCESS;
2411 }
2412
2413
2414 gfc_try
2415 gfc_check_present (gfc_expr *a)
2416 {
2417 gfc_symbol *sym;
2418
2419 if (variable_check (a, 0) == FAILURE)
2420 return FAILURE;
2421
2422 sym = a->symtree->n.sym;
2423 if (!sym->attr.dummy)
2424 {
2425 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2426 "dummy variable", gfc_current_intrinsic_arg[0],
2427 gfc_current_intrinsic, &a->where);
2428 return FAILURE;
2429 }
2430
2431 if (!sym->attr.optional)
2432 {
2433 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2434 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2435 gfc_current_intrinsic, &a->where);
2436 return FAILURE;
2437 }
2438
2439 /* 13.14.82 PRESENT(A)
2440 ......
2441 Argument. A shall be the name of an optional dummy argument that is
2442 accessible in the subprogram in which the PRESENT function reference
2443 appears... */
2444
2445 if (a->ref != NULL
2446 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2447 && a->ref->u.ar.type == AR_FULL))
2448 {
2449 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2450 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2451 gfc_current_intrinsic, &a->where, sym->name);
2452 return FAILURE;
2453 }
2454
2455 return SUCCESS;
2456 }
2457
2458
2459 gfc_try
2460 gfc_check_radix (gfc_expr *x)
2461 {
2462 if (int_or_real_check (x, 0) == FAILURE)
2463 return FAILURE;
2464
2465 return SUCCESS;
2466 }
2467
2468
2469 gfc_try
2470 gfc_check_range (gfc_expr *x)
2471 {
2472 if (numeric_check (x, 0) == FAILURE)
2473 return FAILURE;
2474
2475 return SUCCESS;
2476 }
2477
2478
2479 /* real, float, sngl. */
2480 gfc_try
2481 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2482 {
2483 if (numeric_check (a, 0) == FAILURE)
2484 return FAILURE;
2485
2486 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2487 return FAILURE;
2488
2489 return SUCCESS;
2490 }
2491
2492
2493 gfc_try
2494 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2495 {
2496 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2497 return FAILURE;
2498 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2499 return FAILURE;
2500
2501 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2502 return FAILURE;
2503 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2504 return FAILURE;
2505
2506 return SUCCESS;
2507 }
2508
2509
2510 gfc_try
2511 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2512 {
2513 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2514 return FAILURE;
2515 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2516 return FAILURE;
2517
2518 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2519 return FAILURE;
2520 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2521 return FAILURE;
2522
2523 if (status == NULL)
2524 return SUCCESS;
2525
2526 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2527 return FAILURE;
2528
2529 if (scalar_check (status, 2) == FAILURE)
2530 return FAILURE;
2531
2532 return SUCCESS;
2533 }
2534
2535
2536 gfc_try
2537 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2538 {
2539 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2540 return FAILURE;
2541
2542 if (scalar_check (x, 0) == FAILURE)
2543 return FAILURE;
2544
2545 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2546 return FAILURE;
2547
2548 if (scalar_check (y, 1) == FAILURE)
2549 return FAILURE;
2550
2551 return SUCCESS;
2552 }
2553
2554
2555 gfc_try
2556 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2557 gfc_expr *pad, gfc_expr *order)
2558 {
2559 mpz_t size;
2560 mpz_t nelems;
2561 int shape_size;
2562
2563 if (array_check (source, 0) == FAILURE)
2564 return FAILURE;
2565
2566 if (rank_check (shape, 1, 1) == FAILURE)
2567 return FAILURE;
2568
2569 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2570 return FAILURE;
2571
2572 if (gfc_array_size (shape, &size) != SUCCESS)
2573 {
2574 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2575 "array of constant size", &shape->where);
2576 return FAILURE;
2577 }
2578
2579 shape_size = mpz_get_ui (size);
2580 mpz_clear (size);
2581
2582 if (shape_size <= 0)
2583 {
2584 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2585 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2586 &shape->where);
2587 return FAILURE;
2588 }
2589 else if (shape_size > GFC_MAX_DIMENSIONS)
2590 {
2591 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2592 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2593 return FAILURE;
2594 }
2595 else if (shape->expr_type == EXPR_ARRAY)
2596 {
2597 gfc_expr *e;
2598 int i, extent;
2599 for (i = 0; i < shape_size; ++i)
2600 {
2601 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
2602 if (e->expr_type != EXPR_CONSTANT)
2603 continue;
2604
2605 gfc_extract_int (e, &extent);
2606 if (extent < 0)
2607 {
2608 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2609 "negative element (%d)", gfc_current_intrinsic_arg[1],
2610 gfc_current_intrinsic, &e->where, extent);
2611 return FAILURE;
2612 }
2613 }
2614 }
2615
2616 if (pad != NULL)
2617 {
2618 if (same_type_check (source, 0, pad, 2) == FAILURE)
2619 return FAILURE;
2620
2621 if (array_check (pad, 2) == FAILURE)
2622 return FAILURE;
2623 }
2624
2625 if (order != NULL)
2626 {
2627 if (array_check (order, 3) == FAILURE)
2628 return FAILURE;
2629
2630 if (type_check (order, 3, BT_INTEGER) == FAILURE)
2631 return FAILURE;
2632
2633 if (order->expr_type == EXPR_ARRAY)
2634 {
2635 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2636 gfc_expr *e;
2637
2638 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2639 perm[i] = 0;
2640
2641 gfc_array_size (order, &size);
2642 order_size = mpz_get_ui (size);
2643 mpz_clear (size);
2644
2645 if (order_size != shape_size)
2646 {
2647 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2648 "has wrong number of elements (%d/%d)",
2649 gfc_current_intrinsic_arg[3],
2650 gfc_current_intrinsic, &order->where,
2651 order_size, shape_size);
2652 return FAILURE;
2653 }
2654
2655 for (i = 1; i <= order_size; ++i)
2656 {
2657 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
2658 if (e->expr_type != EXPR_CONSTANT)
2659 continue;
2660
2661 gfc_extract_int (e, &dim);
2662
2663 if (dim < 1 || dim > order_size)
2664 {
2665 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2666 "has out-of-range dimension (%d)",
2667 gfc_current_intrinsic_arg[3],
2668 gfc_current_intrinsic, &e->where, dim);
2669 return FAILURE;
2670 }
2671
2672 if (perm[dim-1] != 0)
2673 {
2674 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2675 "invalid permutation of dimensions (dimension "
2676 "'%d' duplicated)", gfc_current_intrinsic_arg[3],
2677 gfc_current_intrinsic, &e->where, dim);
2678 return FAILURE;
2679 }
2680
2681 perm[dim-1] = 1;
2682 }
2683 }
2684 }
2685
2686 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2687 && gfc_is_constant_expr (shape)
2688 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2689 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2690 {
2691 /* Check the match in size between source and destination. */
2692 if (gfc_array_size (source, &nelems) == SUCCESS)
2693 {
2694 gfc_constructor *c;
2695 bool test;
2696
2697
2698 mpz_init_set_ui (size, 1);
2699 for (c = gfc_constructor_first (shape->value.constructor);
2700 c; c = gfc_constructor_next (c))
2701 mpz_mul (size, size, c->expr->value.integer);
2702
2703 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2704 mpz_clear (nelems);
2705 mpz_clear (size);
2706
2707 if (test)
2708 {
2709 gfc_error ("Without padding, there are not enough elements "
2710 "in the intrinsic RESHAPE source at %L to match "
2711 "the shape", &source->where);
2712 return FAILURE;
2713 }
2714 }
2715 }
2716
2717 return SUCCESS;
2718 }
2719
2720
2721 gfc_try
2722 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
2723 {
2724
2725 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
2726 {
2727 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2728 "must be of a derived type", gfc_current_intrinsic_arg[0],
2729 gfc_current_intrinsic, &a->where);
2730 return FAILURE;
2731 }
2732
2733 if (!gfc_type_is_extensible (a->ts.u.derived))
2734 {
2735 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2736 "must be of an extensible type", gfc_current_intrinsic_arg[0],
2737 gfc_current_intrinsic, &a->where);
2738 return FAILURE;
2739 }
2740
2741 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
2742 {
2743 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2744 "must be of a derived type", gfc_current_intrinsic_arg[1],
2745 gfc_current_intrinsic, &b->where);
2746 return FAILURE;
2747 }
2748
2749 if (!gfc_type_is_extensible (b->ts.u.derived))
2750 {
2751 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2752 "must be of an extensible type", gfc_current_intrinsic_arg[1],
2753 gfc_current_intrinsic, &b->where);
2754 return FAILURE;
2755 }
2756
2757 return SUCCESS;
2758 }
2759
2760
2761 gfc_try
2762 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2763 {
2764 if (type_check (x, 0, BT_REAL) == FAILURE)
2765 return FAILURE;
2766
2767 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2768 return FAILURE;
2769
2770 return SUCCESS;
2771 }
2772
2773
2774 gfc_try
2775 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2776 {
2777 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2778 return FAILURE;
2779
2780 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2781 return FAILURE;
2782
2783 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2784 return FAILURE;
2785
2786 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2787 return FAILURE;
2788 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2789 "with KIND argument at %L",
2790 gfc_current_intrinsic, &kind->where) == FAILURE)
2791 return FAILURE;
2792
2793 if (same_type_check (x, 0, y, 1) == FAILURE)
2794 return FAILURE;
2795
2796 return SUCCESS;
2797 }
2798
2799
2800 gfc_try
2801 gfc_check_secnds (gfc_expr *r)
2802 {
2803 if (type_check (r, 0, BT_REAL) == FAILURE)
2804 return FAILURE;
2805
2806 if (kind_value_check (r, 0, 4) == FAILURE)
2807 return FAILURE;
2808
2809 if (scalar_check (r, 0) == FAILURE)
2810 return FAILURE;
2811
2812 return SUCCESS;
2813 }
2814
2815
2816 gfc_try
2817 gfc_check_selected_char_kind (gfc_expr *name)
2818 {
2819 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2820 return FAILURE;
2821
2822 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2823 return FAILURE;
2824
2825 if (scalar_check (name, 0) == FAILURE)
2826 return FAILURE;
2827
2828 return SUCCESS;
2829 }
2830
2831
2832 gfc_try
2833 gfc_check_selected_int_kind (gfc_expr *r)
2834 {
2835 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2836 return FAILURE;
2837
2838 if (scalar_check (r, 0) == FAILURE)
2839 return FAILURE;
2840
2841 return SUCCESS;
2842 }
2843
2844
2845 gfc_try
2846 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2847 {
2848 if (p == NULL && r == NULL)
2849 {
2850 gfc_error ("Missing arguments to %s intrinsic at %L",
2851 gfc_current_intrinsic, gfc_current_intrinsic_where);
2852
2853 return FAILURE;
2854 }
2855
2856 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2857 return FAILURE;
2858
2859 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2860 return FAILURE;
2861
2862 return SUCCESS;
2863 }
2864
2865
2866 gfc_try
2867 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2868 {
2869 if (type_check (x, 0, BT_REAL) == FAILURE)
2870 return FAILURE;
2871
2872 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2873 return FAILURE;
2874
2875 return SUCCESS;
2876 }
2877
2878
2879 gfc_try
2880 gfc_check_shape (gfc_expr *source)
2881 {
2882 gfc_array_ref *ar;
2883
2884 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2885 return SUCCESS;
2886
2887 ar = gfc_find_array_ref (source);
2888
2889 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2890 {
2891 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2892 "an assumed size array", &source->where);
2893 return FAILURE;
2894 }
2895
2896 return SUCCESS;
2897 }
2898
2899
2900 gfc_try
2901 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2902 {
2903 if (int_or_real_check (a, 0) == FAILURE)
2904 return FAILURE;
2905
2906 if (same_type_check (a, 0, b, 1) == FAILURE)
2907 return FAILURE;
2908
2909 return SUCCESS;
2910 }
2911
2912
2913 gfc_try
2914 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2915 {
2916 if (array_check (array, 0) == FAILURE)
2917 return FAILURE;
2918
2919 if (dim_check (dim, 1, true) == FAILURE)
2920 return FAILURE;
2921
2922 if (dim_rank_check (dim, array, 0) == FAILURE)
2923 return FAILURE;
2924
2925 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2926 return FAILURE;
2927 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2928 "with KIND argument at %L",
2929 gfc_current_intrinsic, &kind->where) == FAILURE)
2930 return FAILURE;
2931
2932
2933 return SUCCESS;
2934 }
2935
2936
2937 gfc_try
2938 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
2939 {
2940 return SUCCESS;
2941 }
2942
2943
2944 gfc_try
2945 gfc_check_sleep_sub (gfc_expr *seconds)
2946 {
2947 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2948 return FAILURE;
2949
2950 if (scalar_check (seconds, 0) == FAILURE)
2951 return FAILURE;
2952
2953 return SUCCESS;
2954 }
2955
2956
2957 gfc_try
2958 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2959 {
2960 if (source->rank >= GFC_MAX_DIMENSIONS)
2961 {
2962 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2963 "than rank %d", gfc_current_intrinsic_arg[0],
2964 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2965
2966 return FAILURE;
2967 }
2968
2969 if (dim == NULL)
2970 return FAILURE;
2971
2972 if (dim_check (dim, 1, false) == FAILURE)
2973 return FAILURE;
2974
2975 /* dim_rank_check() does not apply here. */
2976 if (dim
2977 && dim->expr_type == EXPR_CONSTANT
2978 && (mpz_cmp_ui (dim->value.integer, 1) < 0
2979 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
2980 {
2981 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
2982 "dimension index", gfc_current_intrinsic_arg[1],
2983 gfc_current_intrinsic, &dim->where);
2984 return FAILURE;
2985 }
2986
2987 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2988 return FAILURE;
2989
2990 if (scalar_check (ncopies, 2) == FAILURE)
2991 return FAILURE;
2992
2993 return SUCCESS;
2994 }
2995
2996
2997 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2998 functions). */
2999
3000 gfc_try
3001 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3002 {
3003 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3004 return FAILURE;
3005
3006 if (scalar_check (unit, 0) == FAILURE)
3007 return FAILURE;
3008
3009 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3010 return FAILURE;
3011 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3012 return FAILURE;
3013
3014 if (status == NULL)
3015 return SUCCESS;
3016
3017 if (type_check (status, 2, BT_INTEGER) == FAILURE
3018 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3019 || scalar_check (status, 2) == FAILURE)
3020 return FAILURE;
3021
3022 return SUCCESS;
3023 }
3024
3025
3026 gfc_try
3027 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3028 {
3029 return gfc_check_fgetputc_sub (unit, c, NULL);
3030 }
3031
3032
3033 gfc_try
3034 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3035 {
3036 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3037 return FAILURE;
3038 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3039 return FAILURE;
3040
3041 if (status == NULL)
3042 return SUCCESS;
3043
3044 if (type_check (status, 1, BT_INTEGER) == FAILURE
3045 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3046 || scalar_check (status, 1) == FAILURE)
3047 return FAILURE;
3048
3049 return SUCCESS;
3050 }
3051
3052
3053 gfc_try
3054 gfc_check_fgetput (gfc_expr *c)
3055 {
3056 return gfc_check_fgetput_sub (c, NULL);
3057 }
3058
3059
3060 gfc_try
3061 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3062 {
3063 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3064 return FAILURE;
3065
3066 if (scalar_check (unit, 0) == FAILURE)
3067 return FAILURE;
3068
3069 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3070 return FAILURE;
3071
3072 if (scalar_check (offset, 1) == FAILURE)
3073 return FAILURE;
3074
3075 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3076 return FAILURE;
3077
3078 if (scalar_check (whence, 2) == FAILURE)
3079 return FAILURE;
3080
3081 if (status == NULL)
3082 return SUCCESS;
3083
3084 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3085 return FAILURE;
3086
3087 if (kind_value_check (status, 3, 4) == FAILURE)
3088 return FAILURE;
3089
3090 if (scalar_check (status, 3) == FAILURE)
3091 return FAILURE;
3092
3093 return SUCCESS;
3094 }
3095
3096
3097
3098 gfc_try
3099 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3100 {
3101 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3102 return FAILURE;
3103
3104 if (scalar_check (unit, 0) == FAILURE)
3105 return FAILURE;
3106
3107 if (type_check (array, 1, BT_INTEGER) == FAILURE
3108 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3109 return FAILURE;
3110
3111 if (array_check (array, 1) == FAILURE)
3112 return FAILURE;
3113
3114 return SUCCESS;
3115 }
3116
3117
3118 gfc_try
3119 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3120 {
3121 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3122 return FAILURE;
3123
3124 if (scalar_check (unit, 0) == FAILURE)
3125 return FAILURE;
3126
3127 if (type_check (array, 1, BT_INTEGER) == FAILURE
3128 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3129 return FAILURE;
3130
3131 if (array_check (array, 1) == FAILURE)
3132 return FAILURE;
3133
3134 if (status == NULL)
3135 return SUCCESS;
3136
3137 if (type_check (status, 2, BT_INTEGER) == FAILURE
3138 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3139 return FAILURE;
3140
3141 if (scalar_check (status, 2) == FAILURE)
3142 return FAILURE;
3143
3144 return SUCCESS;
3145 }
3146
3147
3148 gfc_try
3149 gfc_check_ftell (gfc_expr *unit)
3150 {
3151 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3152 return FAILURE;
3153
3154 if (scalar_check (unit, 0) == FAILURE)
3155 return FAILURE;
3156
3157 return SUCCESS;
3158 }
3159
3160
3161 gfc_try
3162 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3163 {
3164 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3165 return FAILURE;
3166
3167 if (scalar_check (unit, 0) == FAILURE)
3168 return FAILURE;
3169
3170 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3171 return FAILURE;
3172
3173 if (scalar_check (offset, 1) == FAILURE)
3174 return FAILURE;
3175
3176 return SUCCESS;
3177 }
3178
3179
3180 gfc_try
3181 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3182 {
3183 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3184 return FAILURE;
3185 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3186 return FAILURE;
3187
3188 if (type_check (array, 1, BT_INTEGER) == FAILURE
3189 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3190 return FAILURE;
3191
3192 if (array_check (array, 1) == FAILURE)
3193 return FAILURE;
3194
3195 return SUCCESS;
3196 }
3197
3198
3199 gfc_try
3200 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3201 {
3202 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3203 return FAILURE;
3204 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3205 return FAILURE;
3206
3207 if (type_check (array, 1, BT_INTEGER) == FAILURE
3208 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3209 return FAILURE;
3210
3211 if (array_check (array, 1) == FAILURE)
3212 return FAILURE;
3213
3214 if (status == NULL)
3215 return SUCCESS;
3216
3217 if (type_check (status, 2, BT_INTEGER) == FAILURE
3218 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3219 return FAILURE;
3220
3221 if (scalar_check (status, 2) == FAILURE)
3222 return FAILURE;
3223
3224 return SUCCESS;
3225 }
3226
3227
3228 gfc_try
3229 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3230 {
3231 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3232 {
3233 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3234 return FAILURE;
3235 }
3236
3237 if (!is_coarray (coarray))
3238 {
3239 gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX "
3240 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3241 return FAILURE;
3242 }
3243
3244 if (sub->rank != 1)
3245 {
3246 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3247 gfc_current_intrinsic_arg[1], &sub->where);
3248 return FAILURE;
3249 }
3250
3251 return SUCCESS;
3252 }
3253
3254
3255 gfc_try
3256 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3257 {
3258 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3259 {
3260 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3261 return FAILURE;
3262 }
3263
3264 if (dim != NULL && coarray == NULL)
3265 {
3266 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3267 "intrinsic at %L", &dim->where);
3268 return FAILURE;
3269 }
3270
3271 if (coarray == NULL)
3272 return SUCCESS;
3273
3274 if (!is_coarray (coarray))
3275 {
3276 gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE "
3277 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3278 return FAILURE;
3279 }
3280
3281 if (dim != NULL)
3282 {
3283 if (dim_check (dim, 1, false) == FAILURE)
3284 return FAILURE;
3285
3286 if (dim_corank_check (dim, coarray) == FAILURE)
3287 return FAILURE;
3288 }
3289
3290 return SUCCESS;
3291 }
3292
3293
3294 gfc_try
3295 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3296 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3297 {
3298 if (mold->ts.type == BT_HOLLERITH)
3299 {
3300 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3301 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3302 return FAILURE;
3303 }
3304
3305 if (size != NULL)
3306 {
3307 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3308 return FAILURE;
3309
3310 if (scalar_check (size, 2) == FAILURE)
3311 return FAILURE;
3312
3313 if (nonoptional_check (size, 2) == FAILURE)
3314 return FAILURE;
3315 }
3316
3317 return SUCCESS;
3318 }
3319
3320
3321 gfc_try
3322 gfc_check_transpose (gfc_expr *matrix)
3323 {
3324 if (rank_check (matrix, 0, 2) == FAILURE)
3325 return FAILURE;
3326
3327 return SUCCESS;
3328 }
3329
3330
3331 gfc_try
3332 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3333 {
3334 if (array_check (array, 0) == FAILURE)
3335 return FAILURE;
3336
3337 if (dim_check (dim, 1, false) == FAILURE)
3338 return FAILURE;
3339
3340 if (dim_rank_check (dim, array, 0) == FAILURE)
3341 return FAILURE;
3342
3343 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3344 return FAILURE;
3345 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3346 "with KIND argument at %L",
3347 gfc_current_intrinsic, &kind->where) == FAILURE)
3348 return FAILURE;
3349
3350 return SUCCESS;
3351 }
3352
3353
3354 gfc_try
3355 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3356 {
3357 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3358 {
3359 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3360 return FAILURE;
3361 }
3362
3363 if (!is_coarray (coarray))
3364 {
3365 gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND "
3366 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3367 return FAILURE;
3368 }
3369
3370 if (dim != NULL)
3371 {
3372 if (dim_check (dim, 1, false) == FAILURE)
3373 return FAILURE;
3374
3375 if (dim_corank_check (dim, coarray) == FAILURE)
3376 return FAILURE;
3377 }
3378
3379 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3380 return FAILURE;
3381
3382 return SUCCESS;
3383 }
3384
3385
3386 gfc_try
3387 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3388 {
3389 mpz_t vector_size;
3390
3391 if (rank_check (vector, 0, 1) == FAILURE)
3392 return FAILURE;
3393
3394 if (array_check (mask, 1) == FAILURE)
3395 return FAILURE;
3396
3397 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3398 return FAILURE;
3399
3400 if (same_type_check (vector, 0, field, 2) == FAILURE)
3401 return FAILURE;
3402
3403 if (mask->expr_type == EXPR_ARRAY
3404 && gfc_array_size (vector, &vector_size) == SUCCESS)
3405 {
3406 int mask_true_count = 0;
3407 gfc_constructor *mask_ctor;
3408 mask_ctor = gfc_constructor_first (mask->value.constructor);
3409 while (mask_ctor)
3410 {
3411 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3412 {
3413 mask_true_count = 0;
3414 break;
3415 }
3416
3417 if (mask_ctor->expr->value.logical)
3418 mask_true_count++;
3419
3420 mask_ctor = gfc_constructor_next (mask_ctor);
3421 }
3422
3423 if (mpz_get_si (vector_size) < mask_true_count)
3424 {
3425 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3426 "provide at least as many elements as there "
3427 "are .TRUE. values in '%s' (%ld/%d)",
3428 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3429 &vector->where, gfc_current_intrinsic_arg[1],
3430 mpz_get_si (vector_size), mask_true_count);
3431 return FAILURE;
3432 }
3433
3434 mpz_clear (vector_size);
3435 }
3436
3437 if (mask->rank != field->rank && field->rank != 0)
3438 {
3439 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3440 "the same rank as '%s' or be a scalar",
3441 gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
3442 &field->where, gfc_current_intrinsic_arg[1]);
3443 return FAILURE;
3444 }
3445
3446 if (mask->rank == field->rank)
3447 {
3448 int i;
3449 for (i = 0; i < field->rank; i++)
3450 if (! identical_dimen_shape (mask, i, field, i))
3451 {
3452 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3453 "must have identical shape.",
3454 gfc_current_intrinsic_arg[2],
3455 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3456 &field->where);
3457 }
3458 }
3459
3460 return SUCCESS;
3461 }
3462
3463
3464 gfc_try
3465 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3466 {
3467 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3468 return FAILURE;
3469
3470 if (same_type_check (x, 0, y, 1) == FAILURE)
3471 return FAILURE;
3472
3473 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3474 return FAILURE;
3475
3476 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3477 return FAILURE;
3478 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3479 "with KIND argument at %L",
3480 gfc_current_intrinsic, &kind->where) == FAILURE)
3481 return FAILURE;
3482
3483 return SUCCESS;
3484 }
3485
3486
3487 gfc_try
3488 gfc_check_trim (gfc_expr *x)
3489 {
3490 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3491 return FAILURE;
3492
3493 if (scalar_check (x, 0) == FAILURE)
3494 return FAILURE;
3495
3496 return SUCCESS;
3497 }
3498
3499
3500 gfc_try
3501 gfc_check_ttynam (gfc_expr *unit)
3502 {
3503 if (scalar_check (unit, 0) == FAILURE)
3504 return FAILURE;
3505
3506 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3507 return FAILURE;
3508
3509 return SUCCESS;
3510 }
3511
3512
3513 /* Common check function for the half a dozen intrinsics that have a
3514 single real argument. */
3515
3516 gfc_try
3517 gfc_check_x (gfc_expr *x)
3518 {
3519 if (type_check (x, 0, BT_REAL) == FAILURE)
3520 return FAILURE;
3521
3522 return SUCCESS;
3523 }
3524
3525
3526 /************* Check functions for intrinsic subroutines *************/
3527
3528 gfc_try
3529 gfc_check_cpu_time (gfc_expr *time)
3530 {
3531 if (scalar_check (time, 0) == FAILURE)
3532 return FAILURE;
3533
3534 if (type_check (time, 0, BT_REAL) == FAILURE)
3535 return FAILURE;
3536
3537 if (variable_check (time, 0) == FAILURE)
3538 return FAILURE;
3539
3540 return SUCCESS;
3541 }
3542
3543
3544 gfc_try
3545 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3546 gfc_expr *zone, gfc_expr *values)
3547 {
3548 if (date != NULL)
3549 {
3550 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3551 return FAILURE;
3552 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3553 return FAILURE;
3554 if (scalar_check (date, 0) == FAILURE)
3555 return FAILURE;
3556 if (variable_check (date, 0) == FAILURE)
3557 return FAILURE;
3558 }
3559
3560 if (time != NULL)
3561 {
3562 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3563 return FAILURE;
3564 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3565 return FAILURE;
3566 if (scalar_check (time, 1) == FAILURE)
3567 return FAILURE;
3568 if (variable_check (time, 1) == FAILURE)
3569 return FAILURE;
3570 }
3571
3572 if (zone != NULL)
3573 {
3574 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3575 return FAILURE;
3576 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3577 return FAILURE;
3578 if (scalar_check (zone, 2) == FAILURE)
3579 return FAILURE;
3580 if (variable_check (zone, 2) == FAILURE)
3581 return FAILURE;
3582 }
3583
3584 if (values != NULL)
3585 {
3586 if (type_check (values, 3, BT_INTEGER) == FAILURE)
3587 return FAILURE;
3588 if (array_check (values, 3) == FAILURE)
3589 return FAILURE;
3590 if (rank_check (values, 3, 1) == FAILURE)
3591 return FAILURE;
3592 if (variable_check (values, 3) == FAILURE)
3593 return FAILURE;
3594 }
3595
3596 return SUCCESS;
3597 }
3598
3599
3600 gfc_try
3601 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3602 gfc_expr *to, gfc_expr *topos)
3603 {
3604 if (type_check (from, 0, BT_INTEGER) == FAILURE)
3605 return FAILURE;
3606
3607 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3608 return FAILURE;
3609
3610 if (type_check (len, 2, BT_INTEGER) == FAILURE)
3611 return FAILURE;
3612
3613 if (same_type_check (from, 0, to, 3) == FAILURE)
3614 return FAILURE;
3615
3616 if (variable_check (to, 3) == FAILURE)
3617 return FAILURE;
3618
3619 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3620 return FAILURE;
3621
3622 return SUCCESS;
3623 }
3624
3625
3626 gfc_try
3627 gfc_check_random_number (gfc_expr *harvest)
3628 {
3629 if (type_check (harvest, 0, BT_REAL) == FAILURE)
3630 return FAILURE;
3631
3632 if (variable_check (harvest, 0) == FAILURE)
3633 return FAILURE;
3634
3635 return SUCCESS;
3636 }
3637
3638
3639 gfc_try
3640 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3641 {
3642 unsigned int nargs = 0, kiss_size;
3643 locus *where = NULL;
3644 mpz_t put_size, get_size;
3645 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
3646
3647 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3648
3649 /* Keep the number of bytes in sync with kiss_size in
3650 libgfortran/intrinsics/random.c. */
3651 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3652
3653 if (size != NULL)
3654 {
3655 if (size->expr_type != EXPR_VARIABLE
3656 || !size->symtree->n.sym->attr.optional)
3657 nargs++;
3658
3659 if (scalar_check (size, 0) == FAILURE)
3660 return FAILURE;
3661
3662 if (type_check (size, 0, BT_INTEGER) == FAILURE)
3663 return FAILURE;
3664
3665 if (variable_check (size, 0) == FAILURE)
3666 return FAILURE;
3667
3668 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3669 return FAILURE;
3670 }
3671
3672 if (put != NULL)
3673 {
3674 if (put->expr_type != EXPR_VARIABLE
3675 || !put->symtree->n.sym->attr.optional)
3676 {
3677 nargs++;
3678 where = &put->where;
3679 }
3680
3681 if (array_check (put, 1) == FAILURE)
3682 return FAILURE;
3683
3684 if (rank_check (put, 1, 1) == FAILURE)
3685 return FAILURE;
3686
3687 if (type_check (put, 1, BT_INTEGER) == FAILURE)
3688 return FAILURE;
3689
3690 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3691 return FAILURE;
3692
3693 if (gfc_array_size (put, &put_size) == SUCCESS
3694 && mpz_get_ui (put_size) < kiss_size)
3695 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3696 "too small (%i/%i)",
3697 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
3698 (int) mpz_get_ui (put_size), kiss_size);
3699 }
3700
3701 if (get != NULL)
3702 {
3703 if (get->expr_type != EXPR_VARIABLE
3704 || !get->symtree->n.sym->attr.optional)
3705 {
3706 nargs++;
3707 where = &get->where;
3708 }
3709
3710 if (array_check (get, 2) == FAILURE)
3711 return FAILURE;
3712
3713 if (rank_check (get, 2, 1) == FAILURE)
3714 return FAILURE;
3715
3716 if (type_check (get, 2, BT_INTEGER) == FAILURE)
3717 return FAILURE;
3718
3719 if (variable_check (get, 2) == FAILURE)
3720 return FAILURE;
3721
3722 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3723 return FAILURE;
3724
3725 if (gfc_array_size (get, &get_size) == SUCCESS
3726 && mpz_get_ui (get_size) < kiss_size)
3727 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3728 "too small (%i/%i)",
3729 gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
3730 (int) mpz_get_ui (get_size), kiss_size);
3731 }
3732
3733 /* RANDOM_SEED may not have more than one non-optional argument. */
3734 if (nargs > 1)
3735 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3736
3737 return SUCCESS;
3738 }
3739
3740
3741 gfc_try
3742 gfc_check_second_sub (gfc_expr *time)
3743 {
3744 if (scalar_check (time, 0) == FAILURE)
3745 return FAILURE;
3746
3747 if (type_check (time, 0, BT_REAL) == FAILURE)
3748 return FAILURE;
3749
3750 if (kind_value_check(time, 0, 4) == FAILURE)
3751 return FAILURE;
3752
3753 return SUCCESS;
3754 }
3755
3756
3757 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3758 count, count_rate, and count_max are all optional arguments */
3759
3760 gfc_try
3761 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3762 gfc_expr *count_max)
3763 {
3764 if (count != NULL)
3765 {
3766 if (scalar_check (count, 0) == FAILURE)
3767 return FAILURE;
3768
3769 if (type_check (count, 0, BT_INTEGER) == FAILURE)
3770 return FAILURE;
3771
3772 if (variable_check (count, 0) == FAILURE)
3773 return FAILURE;
3774 }
3775
3776 if (count_rate != NULL)
3777 {
3778 if (scalar_check (count_rate, 1) == FAILURE)
3779 return FAILURE;
3780
3781 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3782 return FAILURE;
3783
3784 if (variable_check (count_rate, 1) == FAILURE)
3785 return FAILURE;
3786
3787 if (count != NULL
3788 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3789 return FAILURE;
3790
3791 }
3792
3793 if (count_max != NULL)
3794 {
3795 if (scalar_check (count_max, 2) == FAILURE)
3796 return FAILURE;
3797
3798 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3799 return FAILURE;
3800
3801 if (variable_check (count_max, 2) == FAILURE)
3802 return FAILURE;
3803
3804 if (count != NULL
3805 && same_type_check (count, 0, count_max, 2) == FAILURE)
3806 return FAILURE;
3807
3808 if (count_rate != NULL
3809 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3810 return FAILURE;
3811 }
3812
3813 return SUCCESS;
3814 }
3815
3816
3817 gfc_try
3818 gfc_check_irand (gfc_expr *x)
3819 {
3820 if (x == NULL)
3821 return SUCCESS;
3822
3823 if (scalar_check (x, 0) == FAILURE)
3824 return FAILURE;
3825
3826 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3827 return FAILURE;
3828
3829 if (kind_value_check(x, 0, 4) == FAILURE)
3830 return FAILURE;
3831
3832 return SUCCESS;
3833 }
3834
3835
3836 gfc_try
3837 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3838 {
3839 if (scalar_check (seconds, 0) == FAILURE)
3840 return FAILURE;
3841
3842 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3843 return FAILURE;
3844
3845 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3846 {
3847 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3848 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3849 gfc_current_intrinsic, &handler->where);
3850 return FAILURE;
3851 }
3852
3853 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3854 return FAILURE;
3855
3856 if (status == NULL)
3857 return SUCCESS;
3858
3859 if (scalar_check (status, 2) == FAILURE)
3860 return FAILURE;
3861
3862 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3863 return FAILURE;
3864
3865 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3866 return FAILURE;
3867
3868 return SUCCESS;
3869 }
3870
3871
3872 gfc_try
3873 gfc_check_rand (gfc_expr *x)
3874 {
3875 if (x == NULL)
3876 return SUCCESS;
3877
3878 if (scalar_check (x, 0) == FAILURE)
3879 return FAILURE;
3880
3881 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3882 return FAILURE;
3883
3884 if (kind_value_check(x, 0, 4) == FAILURE)
3885 return FAILURE;
3886
3887 return SUCCESS;
3888 }
3889
3890
3891 gfc_try
3892 gfc_check_srand (gfc_expr *x)
3893 {
3894 if (scalar_check (x, 0) == FAILURE)
3895 return FAILURE;
3896
3897 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3898 return FAILURE;
3899
3900 if (kind_value_check(x, 0, 4) == FAILURE)
3901 return FAILURE;
3902
3903 return SUCCESS;
3904 }
3905
3906
3907 gfc_try
3908 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3909 {
3910 if (scalar_check (time, 0) == FAILURE)
3911 return FAILURE;
3912 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3913 return FAILURE;
3914
3915 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3916 return FAILURE;
3917 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3918 return FAILURE;
3919
3920 return SUCCESS;
3921 }
3922
3923
3924 gfc_try
3925 gfc_check_dtime_etime (gfc_expr *x)
3926 {
3927 if (array_check (x, 0) == FAILURE)
3928 return FAILURE;
3929
3930 if (rank_check (x, 0, 1) == FAILURE)
3931 return FAILURE;
3932
3933 if (variable_check (x, 0) == FAILURE)
3934 return FAILURE;
3935
3936 if (type_check (x, 0, BT_REAL) == FAILURE)
3937 return FAILURE;
3938
3939 if (kind_value_check(x, 0, 4) == FAILURE)
3940 return FAILURE;
3941
3942 return SUCCESS;
3943 }
3944
3945
3946 gfc_try
3947 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3948 {
3949 if (array_check (values, 0) == FAILURE)
3950 return FAILURE;
3951
3952 if (rank_check (values, 0, 1) == FAILURE)
3953 return FAILURE;
3954
3955 if (variable_check (values, 0) == FAILURE)
3956 return FAILURE;
3957
3958 if (type_check (values, 0, BT_REAL) == FAILURE)
3959 return FAILURE;
3960
3961 if (kind_value_check(values, 0, 4) == FAILURE)
3962 return FAILURE;
3963
3964 if (scalar_check (time, 1) == FAILURE)
3965 return FAILURE;
3966
3967 if (type_check (time, 1, BT_REAL) == FAILURE)
3968 return FAILURE;
3969
3970 if (kind_value_check(time, 1, 4) == FAILURE)
3971 return FAILURE;
3972
3973 return SUCCESS;
3974 }
3975
3976
3977 gfc_try
3978 gfc_check_fdate_sub (gfc_expr *date)
3979 {
3980 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3981 return FAILURE;
3982 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3983 return FAILURE;
3984
3985 return SUCCESS;
3986 }
3987
3988
3989 gfc_try
3990 gfc_check_gerror (gfc_expr *msg)
3991 {
3992 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3993 return FAILURE;
3994 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3995 return FAILURE;
3996
3997 return SUCCESS;
3998 }
3999
4000
4001 gfc_try
4002 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4003 {
4004 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4005 return FAILURE;
4006 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4007 return FAILURE;
4008
4009 if (status == NULL)
4010 return SUCCESS;
4011
4012 if (scalar_check (status, 1) == FAILURE)
4013 return FAILURE;
4014
4015 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4016 return FAILURE;
4017
4018 return SUCCESS;
4019 }
4020
4021
4022 gfc_try
4023 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4024 {
4025 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4026 return FAILURE;
4027
4028 if (pos->ts.kind > gfc_default_integer_kind)
4029 {
4030 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4031 "not wider than the default kind (%d)",
4032 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
4033 &pos->where, gfc_default_integer_kind);
4034 return FAILURE;
4035 }
4036
4037 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4038 return FAILURE;
4039 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4040 return FAILURE;
4041
4042 return SUCCESS;
4043 }
4044
4045
4046 gfc_try
4047 gfc_check_getlog (gfc_expr *msg)
4048 {
4049 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4050 return FAILURE;
4051 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4052 return FAILURE;
4053
4054 return SUCCESS;
4055 }
4056
4057
4058 gfc_try
4059 gfc_check_exit (gfc_expr *status)
4060 {
4061 if (status == NULL)
4062 return SUCCESS;
4063
4064 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4065 return FAILURE;
4066
4067 if (scalar_check (status, 0) == FAILURE)
4068 return FAILURE;
4069
4070 return SUCCESS;
4071 }
4072
4073
4074 gfc_try
4075 gfc_check_flush (gfc_expr *unit)
4076 {
4077 if (unit == NULL)
4078 return SUCCESS;
4079
4080 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4081 return FAILURE;
4082
4083 if (scalar_check (unit, 0) == FAILURE)
4084 return FAILURE;
4085
4086 return SUCCESS;
4087 }
4088
4089
4090 gfc_try
4091 gfc_check_free (gfc_expr *i)
4092 {
4093 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4094 return FAILURE;
4095
4096 if (scalar_check (i, 0) == FAILURE)
4097 return FAILURE;
4098
4099 return SUCCESS;
4100 }
4101
4102
4103 gfc_try
4104 gfc_check_hostnm (gfc_expr *name)
4105 {
4106 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4107 return FAILURE;
4108 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4109 return FAILURE;
4110
4111 return SUCCESS;
4112 }
4113
4114
4115 gfc_try
4116 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4117 {
4118 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4119 return FAILURE;
4120 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4121 return FAILURE;
4122
4123 if (status == NULL)
4124 return SUCCESS;
4125
4126 if (scalar_check (status, 1) == FAILURE)
4127 return FAILURE;
4128
4129 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4130 return FAILURE;
4131
4132 return SUCCESS;
4133 }
4134
4135
4136 gfc_try
4137 gfc_check_itime_idate (gfc_expr *values)
4138 {
4139 if (array_check (values, 0) == FAILURE)
4140 return FAILURE;
4141
4142 if (rank_check (values, 0, 1) == FAILURE)
4143 return FAILURE;
4144
4145 if (variable_check (values, 0) == FAILURE)
4146 return FAILURE;
4147
4148 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4149 return FAILURE;
4150
4151 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4152 return FAILURE;
4153
4154 return SUCCESS;
4155 }
4156
4157
4158 gfc_try
4159 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4160 {
4161 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4162 return FAILURE;
4163
4164 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4165 return FAILURE;
4166
4167 if (scalar_check (time, 0) == FAILURE)
4168 return FAILURE;
4169
4170 if (array_check (values, 1) == FAILURE)
4171 return FAILURE;
4172
4173 if (rank_check (values, 1, 1) == FAILURE)
4174 return FAILURE;
4175
4176 if (variable_check (values, 1) == FAILURE)
4177 return FAILURE;
4178
4179 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4180 return FAILURE;
4181
4182 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4183 return FAILURE;
4184
4185 return SUCCESS;
4186 }
4187
4188
4189 gfc_try
4190 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4191 {
4192 if (scalar_check (unit, 0) == FAILURE)
4193 return FAILURE;
4194
4195 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4196 return FAILURE;
4197
4198 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4199 return FAILURE;
4200 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4201 return FAILURE;
4202
4203 return SUCCESS;
4204 }
4205
4206
4207 gfc_try
4208 gfc_check_isatty (gfc_expr *unit)
4209 {
4210 if (unit == NULL)
4211 return FAILURE;
4212
4213 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4214 return FAILURE;
4215
4216 if (scalar_check (unit, 0) == FAILURE)
4217 return FAILURE;
4218
4219 return SUCCESS;
4220 }
4221
4222
4223 gfc_try
4224 gfc_check_isnan (gfc_expr *x)
4225 {
4226 if (type_check (x, 0, BT_REAL) == FAILURE)
4227 return FAILURE;
4228
4229 return SUCCESS;
4230 }
4231
4232
4233 gfc_try
4234 gfc_check_perror (gfc_expr *string)
4235 {
4236 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4237 return FAILURE;
4238 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4239 return FAILURE;
4240
4241 return SUCCESS;
4242 }
4243
4244
4245 gfc_try
4246 gfc_check_umask (gfc_expr *mask)
4247 {
4248 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4249 return FAILURE;
4250
4251 if (scalar_check (mask, 0) == FAILURE)
4252 return FAILURE;
4253
4254 return SUCCESS;
4255 }
4256
4257
4258 gfc_try
4259 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4260 {
4261 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4262 return FAILURE;
4263
4264 if (scalar_check (mask, 0) == FAILURE)
4265 return FAILURE;
4266
4267 if (old == NULL)
4268 return SUCCESS;
4269
4270 if (scalar_check (old, 1) == FAILURE)
4271 return FAILURE;
4272
4273 if (type_check (old, 1, BT_INTEGER) == FAILURE)
4274 return FAILURE;
4275
4276 return SUCCESS;
4277 }
4278
4279
4280 gfc_try
4281 gfc_check_unlink (gfc_expr *name)
4282 {
4283 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4284 return FAILURE;
4285 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4286 return FAILURE;
4287
4288 return SUCCESS;
4289 }
4290
4291
4292 gfc_try
4293 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4294 {
4295 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4296 return FAILURE;
4297 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4298 return FAILURE;
4299
4300 if (status == NULL)
4301 return SUCCESS;
4302
4303 if (scalar_check (status, 1) == FAILURE)
4304 return FAILURE;
4305
4306 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4307 return FAILURE;
4308
4309 return SUCCESS;
4310 }
4311
4312
4313 gfc_try
4314 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4315 {
4316 if (scalar_check (number, 0) == FAILURE)
4317 return FAILURE;
4318
4319 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4320 return FAILURE;
4321
4322 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4323 {
4324 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4325 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4326 gfc_current_intrinsic, &handler->where);
4327 return FAILURE;
4328 }
4329
4330 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4331 return FAILURE;
4332
4333 return SUCCESS;
4334 }
4335
4336
4337 gfc_try
4338 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4339 {
4340 if (scalar_check (number, 0) == FAILURE)
4341 return FAILURE;
4342
4343 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4344 return FAILURE;
4345
4346 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4347 {
4348 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4349 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4350 gfc_current_intrinsic, &handler->where);
4351 return FAILURE;
4352 }
4353
4354 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4355 return FAILURE;
4356
4357 if (status == NULL)
4358 return SUCCESS;
4359
4360 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4361 return FAILURE;
4362
4363 if (scalar_check (status, 2) == FAILURE)
4364 return FAILURE;
4365
4366 return SUCCESS;
4367 }
4368
4369
4370 gfc_try
4371 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4372 {
4373 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4374 return FAILURE;
4375 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4376 return FAILURE;
4377
4378 if (scalar_check (status, 1) == FAILURE)
4379 return FAILURE;
4380
4381 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4382 return FAILURE;
4383
4384 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4385 return FAILURE;
4386
4387 return SUCCESS;
4388 }
4389
4390
4391 /* This is used for the GNU intrinsics AND, OR and XOR. */
4392 gfc_try
4393 gfc_check_and (gfc_expr *i, gfc_expr *j)
4394 {
4395 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4396 {
4397 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4398 "or LOGICAL", gfc_current_intrinsic_arg[0],
4399 gfc_current_intrinsic, &i->where);
4400 return FAILURE;
4401 }
4402
4403 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4404 {
4405 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4406 "or LOGICAL", gfc_current_intrinsic_arg[1],
4407 gfc_current_intrinsic, &j->where);
4408 return FAILURE;
4409 }
4410
4411 if (i->ts.type != j->ts.type)
4412 {
4413 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4414 "have the same type", gfc_current_intrinsic_arg[0],
4415 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
4416 &j->where);
4417 return FAILURE;
4418 }
4419
4420 if (scalar_check (i, 0) == FAILURE)
4421 return FAILURE;
4422
4423 if (scalar_check (j, 1) == FAILURE)
4424 return FAILURE;
4425
4426 return SUCCESS;
4427 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org