]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/iresolve.cc
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
tree-optimization/116791 - Elementwise SLP vectorization
[thirdparty/gcc.git] / gcc / fortran / iresolve.cc
1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2024 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21
22 /* Assign name and types to intrinsic procedures. For functions, the
23 first argument to a resolution function is an expression pointer to
24 the original function node and the rest are pointers to the
25 arguments of the function call. For subroutines, a pointer to the
26 code node is passed. The result type and library subroutine name
27 are generally set according to the function arguments. */
28
29 #include "config.h"
30 #include "system.h"
31 #include "coretypes.h"
32 #include "tree.h"
33 #include "gfortran.h"
34 #include "stringpool.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
37 #include "arith.h"
38 #include "trans.h"
39
40 /* Given printf-like arguments, return a stable version of the result string.
41
42 We already have a working, optimized string hashing table in the form of
43 the identifier table. Reusing this table is likely not to be wasted,
44 since if the function name makes it to the gimple output of the frontend,
45 we'll have to create the identifier anyway. */
46
47 const char *
48 gfc_get_string (const char *format, ...)
49 {
50 /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 const char *str;
53 va_list ap;
54 tree ident;
55
56 /* Handle common case without vsnprintf and temporary buffer. */
57 if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 {
59 va_start (ap, format);
60 str = va_arg (ap, const char *);
61 va_end (ap);
62 }
63 else
64 {
65 int ret;
66 va_start (ap, format);
67 ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 va_end (ap);
69 if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 gfc_internal_error ("identifier overflow: %d", ret);
71 temp_name[sizeof (temp_name) - 1] = 0;
72 str = temp_name;
73 }
74
75 ident = get_identifier (str);
76 return IDENTIFIER_POINTER (ident);
77 }
78
79 /* MERGE and SPREAD need to have source charlen's present for passing
80 to the result expression. */
81 static void
82 check_charlen_present (gfc_expr *source)
83 {
84 if (source->ts.u.cl == NULL)
85 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
86
87 if (source->expr_type == EXPR_CONSTANT)
88 {
89 source->ts.u.cl->length
90 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
91 source->value.character.length);
92 source->rank = 0;
93 }
94 else if (source->expr_type == EXPR_ARRAY)
95 {
96 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
97 if (c)
98 source->ts.u.cl->length
99 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
100 c->expr->value.character.length);
101 if (source->ts.u.cl->length == NULL)
102 gfc_internal_error ("check_charlen_present(): length not set");
103 }
104 }
105
106 /* Helper function for resolving the "mask" argument. */
107
108 static void
109 resolve_mask_arg (gfc_expr *mask)
110 {
111
112 gfc_typespec ts;
113 gfc_clear_ts (&ts);
114
115 if (mask->rank == 0)
116 {
117 /* For the scalar case, coerce the mask to kind=4 unconditionally
118 (because this is the only kind we have a library function
119 for). */
120
121 if (mask->ts.kind != 4)
122 {
123 ts.type = BT_LOGICAL;
124 ts.kind = 4;
125 gfc_convert_type (mask, &ts, 2);
126 }
127 }
128 else
129 {
130 /* In the library, we access the mask with a GFC_LOGICAL_1
131 argument. No need to waste memory if we are about to create
132 a temporary array. */
133 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
134 {
135 ts.type = BT_LOGICAL;
136 ts.kind = 1;
137 gfc_convert_type_warn (mask, &ts, 2, 0);
138 }
139 }
140 }
141
142
143 static void
144 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145 const char *name, bool coarray)
146 {
147 f->ts.type = BT_INTEGER;
148 if (kind)
149 f->ts.kind = mpz_get_si (kind->value.integer);
150 else
151 f->ts.kind = gfc_default_integer_kind;
152
153 if (dim == NULL)
154 {
155 if (array->rank != -1)
156 {
157 /* Assume f->rank gives the size of the shape, because there is no
158 other way to determine the size. */
159 if (!f->shape || f->rank != 1)
160 {
161 if (f->shape)
162 gfc_free_shape (&f->shape, f->rank);
163 f->shape = gfc_get_shape (1);
164 }
165 mpz_init_set_ui (f->shape[0], coarray ? array->corank : array->rank);
166 }
167 /* Applying bound to a coarray always results in a regular array. */
168 f->rank = 1;
169 f->corank = 0;
170 }
171
172 f->value.function.name = gfc_get_string ("%s", name);
173 }
174
175
176 static void
177 resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
178 gfc_expr *dim, gfc_expr *mask)
179 {
180 const char *prefix;
181
182 f->ts = array->ts;
183
184 if (mask)
185 {
186 if (mask->rank == 0)
187 prefix = "s";
188 else
189 prefix = "m";
190
191 resolve_mask_arg (mask);
192 }
193 else
194 prefix = "";
195
196 if (dim != NULL)
197 {
198 f->rank = array->rank - 1;
199 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
200 gfc_resolve_dim_arg (dim);
201 }
202
203 f->value.function.name
204 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
205 gfc_type_letter (array->ts.type),
206 gfc_type_abi_kind (&array->ts));
207 }
208
209
210 /********************** Resolution functions **********************/
211
212
213 void
214 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
215 {
216 f->ts = a->ts;
217 if (f->ts.type == BT_COMPLEX)
218 f->ts.type = BT_REAL;
219
220 f->value.function.name
221 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
222 gfc_type_abi_kind (&a->ts));
223 }
224
225
226 void
227 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
228 gfc_expr *mode ATTRIBUTE_UNUSED)
229 {
230 f->ts.type = BT_INTEGER;
231 f->ts.kind = gfc_c_int_kind;
232 f->value.function.name = PREFIX ("access_func");
233 }
234
235
236 void
237 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
238 {
239 f->ts.type = BT_CHARACTER;
240 f->ts.kind = string->ts.kind;
241 if (string->ts.deferred)
242 f->ts = string->ts;
243 else if (string->ts.u.cl)
244 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
245
246 f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
247 }
248
249
250 void
251 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
252 {
253 f->ts.type = BT_CHARACTER;
254 f->ts.kind = string->ts.kind;
255 if (string->ts.deferred)
256 f->ts = string->ts;
257 else if (string->ts.u.cl)
258 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
259
260 f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
261 }
262
263
264 static void
265 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
266 bool is_achar)
267 {
268 f->ts.type = BT_CHARACTER;
269 f->ts.kind = (kind == NULL)
270 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
271 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
272 f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
273
274 f->value.function.name
275 = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
276 gfc_type_letter (x->ts.type),
277 gfc_type_abi_kind (&x->ts));
278 }
279
280
281 void
282 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
283 {
284 gfc_resolve_char_achar (f, x, kind, true);
285 }
286
287
288 void
289 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
290 {
291 f->ts = x->ts;
292 f->value.function.name
293 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type),
294 gfc_type_abi_kind (&x->ts));
295 }
296
297
298 void
299 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
300 {
301 f->ts = x->ts;
302 f->value.function.name
303 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
304 gfc_type_abi_kind (&x->ts));
305 }
306
307
308 void
309 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
310 {
311 f->ts.type = BT_REAL;
312 f->ts.kind = x->ts.kind;
313 f->value.function.name
314 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
315 gfc_type_abi_kind (&x->ts));
316 }
317
318
319 void
320 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
321 {
322 f->ts.type = i->ts.type;
323 f->ts.kind = gfc_kind_max (i, j);
324
325 if (i->ts.kind != j->ts.kind)
326 {
327 if (i->ts.kind == gfc_kind_max (i, j))
328 gfc_convert_type (j, &i->ts, 2);
329 else
330 gfc_convert_type (i, &j->ts, 2);
331 }
332
333 f->value.function.name
334 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type),
335 gfc_type_abi_kind (&f->ts));
336 }
337
338
339 void
340 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
341 {
342 gfc_typespec ts;
343 gfc_clear_ts (&ts);
344
345 f->ts.type = a->ts.type;
346 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
347
348 if (a->ts.kind != f->ts.kind)
349 {
350 ts.type = f->ts.type;
351 ts.kind = f->ts.kind;
352 gfc_convert_type (a, &ts, 2);
353 }
354 /* The resolved name is only used for specific intrinsics where
355 the return kind is the same as the arg kind. */
356 f->value.function.name
357 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type),
358 gfc_type_abi_kind (&a->ts));
359 }
360
361
362 void
363 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
364 {
365 gfc_resolve_aint (f, a, NULL);
366 }
367
368
369 void
370 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
371 {
372 f->ts = mask->ts;
373
374 if (dim != NULL)
375 {
376 gfc_resolve_dim_arg (dim);
377 f->rank = mask->rank - 1;
378 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
379 }
380
381 f->value.function.name
382 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
383 gfc_type_abi_kind (&mask->ts));
384 }
385
386
387 void
388 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
389 {
390 gfc_typespec ts;
391 gfc_clear_ts (&ts);
392
393 f->ts.type = a->ts.type;
394 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
395
396 if (a->ts.kind != f->ts.kind)
397 {
398 ts.type = f->ts.type;
399 ts.kind = f->ts.kind;
400 gfc_convert_type (a, &ts, 2);
401 }
402
403 /* The resolved name is only used for specific intrinsics where
404 the return kind is the same as the arg kind. */
405 f->value.function.name
406 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
407 gfc_type_abi_kind (&a->ts));
408 }
409
410
411 void
412 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
413 {
414 gfc_resolve_anint (f, a, NULL);
415 }
416
417
418 void
419 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
420 {
421 f->ts = mask->ts;
422
423 if (dim != NULL)
424 {
425 gfc_resolve_dim_arg (dim);
426 f->rank = mask->rank - 1;
427 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
428 }
429
430 f->value.function.name
431 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
432 gfc_type_abi_kind (&mask->ts));
433 }
434
435
436 void
437 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
438 {
439 f->ts = x->ts;
440 f->value.function.name
441 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type),
442 gfc_type_abi_kind (&x->ts));
443 }
444
445 void
446 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
447 {
448 f->ts = x->ts;
449 f->value.function.name
450 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
451 gfc_type_abi_kind (&x->ts));
452 }
453
454 void
455 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
456 {
457 f->ts = x->ts;
458 f->value.function.name
459 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type),
460 gfc_type_abi_kind (&x->ts));
461 }
462
463 void
464 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
465 {
466 f->ts = x->ts;
467 f->value.function.name
468 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
469 gfc_type_abi_kind (&x->ts));
470 }
471
472 void
473 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
474 {
475 f->ts = x->ts;
476 f->value.function.name
477 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
478 gfc_type_abi_kind (&x->ts));
479 }
480
481
482 /* Resolve the BESYN and BESJN intrinsics. */
483
484 void
485 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
486 {
487 gfc_typespec ts;
488 gfc_clear_ts (&ts);
489
490 f->ts = x->ts;
491 if (n->ts.kind != gfc_c_int_kind)
492 {
493 ts.type = BT_INTEGER;
494 ts.kind = gfc_c_int_kind;
495 gfc_convert_type (n, &ts, 2);
496 }
497 f->value.function.name = gfc_get_string ("<intrinsic>");
498 }
499
500
501 void
502 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
503 {
504 gfc_typespec ts;
505 gfc_clear_ts (&ts);
506
507 f->ts = x->ts;
508 f->rank = 1;
509 if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
510 {
511 f->shape = gfc_get_shape (1);
512 mpz_init (f->shape[0]);
513 mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
514 mpz_add_ui (f->shape[0], f->shape[0], 1);
515 }
516
517 if (n1->ts.kind != gfc_c_int_kind)
518 {
519 ts.type = BT_INTEGER;
520 ts.kind = gfc_c_int_kind;
521 gfc_convert_type (n1, &ts, 2);
522 }
523
524 if (n2->ts.kind != gfc_c_int_kind)
525 {
526 ts.type = BT_INTEGER;
527 ts.kind = gfc_c_int_kind;
528 gfc_convert_type (n2, &ts, 2);
529 }
530
531 if (f->value.function.isym->id == GFC_ISYM_JN2)
532 f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
533 gfc_type_abi_kind (&f->ts));
534 else
535 f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
536 gfc_type_abi_kind (&f->ts));
537 }
538
539
540 void
541 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
542 {
543 f->ts.type = BT_LOGICAL;
544 f->ts.kind = gfc_default_logical_kind;
545 f->value.function.name
546 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
547 }
548
549
550 void
551 gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
552 {
553 f->ts = f->value.function.isym->ts;
554 }
555
556
557 void
558 gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
559 {
560 f->ts = f->value.function.isym->ts;
561 }
562
563
564 void
565 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
566 {
567 f->ts.type = BT_INTEGER;
568 f->ts.kind = (kind == NULL)
569 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
570 f->value.function.name
571 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
572 gfc_type_letter (a->ts.type),
573 gfc_type_abi_kind (&a->ts));
574 }
575
576
577 void
578 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
579 {
580 gfc_resolve_char_achar (f, a, kind, false);
581 }
582
583
584 void
585 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
586 {
587 f->ts.type = BT_INTEGER;
588 f->ts.kind = gfc_default_integer_kind;
589 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
590 }
591
592
593 void
594 gfc_resolve_chdir_sub (gfc_code *c)
595 {
596 const char *name;
597 int kind;
598
599 if (c->ext.actual->next->expr != NULL)
600 kind = c->ext.actual->next->expr->ts.kind;
601 else
602 kind = gfc_default_integer_kind;
603
604 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
605 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
606 }
607
608
609 void
610 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
611 gfc_expr *mode ATTRIBUTE_UNUSED)
612 {
613 f->ts.type = BT_INTEGER;
614 f->ts.kind = gfc_c_int_kind;
615 f->value.function.name = PREFIX ("chmod_func");
616 }
617
618
619 void
620 gfc_resolve_chmod_sub (gfc_code *c)
621 {
622 const char *name;
623 int kind;
624
625 if (c->ext.actual->next->next->expr != NULL)
626 kind = c->ext.actual->next->next->expr->ts.kind;
627 else
628 kind = gfc_default_integer_kind;
629
630 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
631 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
632 }
633
634
635 void
636 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
637 {
638 f->ts.type = BT_COMPLEX;
639 f->ts.kind = (kind == NULL)
640 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
641
642 if (y == NULL)
643 f->value.function.name
644 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
645 gfc_type_letter (x->ts.type),
646 gfc_type_abi_kind (&x->ts));
647 else
648 f->value.function.name
649 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
650 gfc_type_letter (x->ts.type),
651 gfc_type_abi_kind (&x->ts),
652 gfc_type_letter (y->ts.type),
653 gfc_type_abi_kind (&y->ts));
654 }
655
656
657 void
658 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
659 {
660 gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
661 gfc_default_double_kind));
662 }
663
664
665 void
666 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
667 {
668 int kind;
669
670 if (x->ts.type == BT_INTEGER)
671 {
672 if (y->ts.type == BT_INTEGER)
673 kind = gfc_default_real_kind;
674 else
675 kind = y->ts.kind;
676 }
677 else
678 {
679 if (y->ts.type == BT_REAL)
680 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
681 else
682 kind = x->ts.kind;
683 }
684
685 f->ts.type = BT_COMPLEX;
686 f->ts.kind = kind;
687 f->value.function.name
688 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
689 gfc_type_letter (x->ts.type),
690 gfc_type_abi_kind (&x->ts),
691 gfc_type_letter (y->ts.type),
692 gfc_type_abi_kind (&y->ts));
693 }
694
695
696 void
697 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
698 {
699 f->ts = x->ts;
700 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
701 }
702
703
704 void
705 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
706 {
707 f->ts = x->ts;
708 f->value.function.name
709 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type),
710 gfc_type_abi_kind (&x->ts));
711 }
712
713
714 void
715 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
716 {
717 f->ts = x->ts;
718 f->value.function.name
719 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type),
720 gfc_type_abi_kind (&x->ts));
721 }
722
723
724 void
725 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
726 {
727 f->ts.type = BT_INTEGER;
728 if (kind)
729 f->ts.kind = mpz_get_si (kind->value.integer);
730 else
731 f->ts.kind = gfc_default_integer_kind;
732
733 if (dim != NULL)
734 {
735 f->rank = mask->rank - 1;
736 gfc_resolve_dim_arg (dim);
737 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
738 }
739
740 resolve_mask_arg (mask);
741
742 f->value.function.name
743 = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts),
744 gfc_type_letter (mask->ts.type));
745 }
746
747
748 void
749 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
750 gfc_expr *dim)
751 {
752 int n, m;
753
754 if (array->ts.type == BT_CHARACTER && array->ref)
755 gfc_resolve_substring_charlen (array);
756
757 f->ts = array->ts;
758 f->rank = array->rank;
759 f->corank = array->corank;
760 f->shape = gfc_copy_shape (array->shape, array->rank);
761
762 if (shift->rank > 0)
763 n = 1;
764 else
765 n = 0;
766
767 /* If dim kind is greater than default integer we need to use the larger. */
768 m = gfc_default_integer_kind;
769 if (dim != NULL)
770 m = m < dim->ts.kind ? dim->ts.kind : m;
771
772 /* Convert shift to at least m, so we don't need
773 kind=1 and kind=2 versions of the library functions. */
774 if (shift->ts.kind < m)
775 {
776 gfc_typespec ts;
777 gfc_clear_ts (&ts);
778 ts.type = BT_INTEGER;
779 ts.kind = m;
780 gfc_convert_type_warn (shift, &ts, 2, 0);
781 }
782
783 if (dim != NULL)
784 {
785 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
786 && dim->symtree->n.sym->attr.optional)
787 {
788 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
789 dim->representation.length = shift->ts.kind;
790 }
791 else
792 {
793 gfc_resolve_dim_arg (dim);
794 /* Convert dim to shift's kind to reduce variations. */
795 if (dim->ts.kind != shift->ts.kind)
796 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
797 }
798 }
799
800 if (array->ts.type == BT_CHARACTER)
801 {
802 if (array->ts.kind == gfc_default_character_kind)
803 f->value.function.name
804 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
805 else
806 f->value.function.name
807 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
808 array->ts.kind);
809 }
810 else
811 f->value.function.name
812 = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
813 }
814
815
816 void
817 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
818 {
819 gfc_typespec ts;
820 gfc_clear_ts (&ts);
821
822 f->ts.type = BT_CHARACTER;
823 f->ts.kind = gfc_default_character_kind;
824
825 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
826 if (time->ts.kind != 8)
827 {
828 ts.type = BT_INTEGER;
829 ts.kind = 8;
830 ts.u.derived = NULL;
831 ts.u.cl = NULL;
832 gfc_convert_type (time, &ts, 2);
833 }
834
835 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
836 }
837
838
839 void
840 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
841 {
842 f->ts.type = BT_REAL;
843 f->ts.kind = gfc_default_double_kind;
844 f->value.function.name
845 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type),
846 gfc_type_abi_kind (&a->ts));
847 }
848
849
850 void
851 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
852 {
853 f->ts.type = a->ts.type;
854 if (p != NULL)
855 f->ts.kind = gfc_kind_max (a,p);
856 else
857 f->ts.kind = a->ts.kind;
858
859 if (p != NULL && a->ts.kind != p->ts.kind)
860 {
861 if (a->ts.kind == gfc_kind_max (a,p))
862 gfc_convert_type (p, &a->ts, 2);
863 else
864 gfc_convert_type (a, &p->ts, 2);
865 }
866
867 f->value.function.name
868 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type),
869 gfc_type_abi_kind (&f->ts));
870 }
871
872
873 void
874 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
875 {
876 gfc_expr temp;
877
878 temp.expr_type = EXPR_OP;
879 gfc_clear_ts (&temp.ts);
880 temp.value.op.op = INTRINSIC_NONE;
881 temp.value.op.op1 = a;
882 temp.value.op.op2 = b;
883 gfc_type_convert_binary (&temp, 1);
884 f->ts = temp.ts;
885 f->value.function.name
886 = gfc_get_string (PREFIX ("dot_product_%c%d"),
887 gfc_type_letter (f->ts.type),
888 gfc_type_abi_kind (&f->ts));
889 }
890
891
892 void
893 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
894 gfc_expr *b ATTRIBUTE_UNUSED)
895 {
896 f->ts.kind = gfc_default_double_kind;
897 f->ts.type = BT_REAL;
898 f->value.function.name = gfc_get_string ("__dprod_r%d",
899 gfc_type_abi_kind (&f->ts));
900 }
901
902
903 void
904 gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
905 gfc_expr *shift ATTRIBUTE_UNUSED)
906 {
907 char c = i->ts.type == BT_INTEGER ? 'i' : 'u';
908
909 f->ts = i->ts;
910 if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
911 f->value.function.name = gfc_get_string ("dshiftl_%c%d", c, f->ts.kind);
912 else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
913 f->value.function.name = gfc_get_string ("dshiftr_%c%d", c, f->ts.kind);
914 else
915 gcc_unreachable ();
916 }
917
918
919 void
920 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
921 gfc_expr *boundary, gfc_expr *dim)
922 {
923 int n, m;
924
925 if (array->ts.type == BT_CHARACTER && array->ref)
926 gfc_resolve_substring_charlen (array);
927
928 f->ts = array->ts;
929 f->rank = array->rank;
930 f->corank = array->corank;
931 f->shape = gfc_copy_shape (array->shape, array->rank);
932
933 n = 0;
934 if (shift->rank > 0)
935 n = n | 1;
936 if (boundary && boundary->rank > 0)
937 n = n | 2;
938
939 /* If dim kind is greater than default integer we need to use the larger. */
940 m = gfc_default_integer_kind;
941 if (dim != NULL)
942 m = m < dim->ts.kind ? dim->ts.kind : m;
943
944 /* Convert shift to at least m, so we don't need
945 kind=1 and kind=2 versions of the library functions. */
946 if (shift->ts.kind < m)
947 {
948 gfc_typespec ts;
949 gfc_clear_ts (&ts);
950 ts.type = BT_INTEGER;
951 ts.kind = m;
952 gfc_convert_type_warn (shift, &ts, 2, 0);
953 }
954
955 if (dim != NULL)
956 {
957 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
958 && dim->symtree->n.sym->attr.optional)
959 {
960 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
961 dim->representation.length = shift->ts.kind;
962 }
963 else
964 {
965 gfc_resolve_dim_arg (dim);
966 /* Convert dim to shift's kind to reduce variations. */
967 if (dim->ts.kind != shift->ts.kind)
968 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
969 }
970 }
971
972 if (array->ts.type == BT_CHARACTER)
973 {
974 if (array->ts.kind == gfc_default_character_kind)
975 f->value.function.name
976 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
977 else
978 f->value.function.name
979 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
980 array->ts.kind);
981 }
982 else
983 f->value.function.name
984 = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
985 }
986
987
988 void
989 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
990 {
991 f->ts = x->ts;
992 f->value.function.name
993 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type),
994 gfc_type_abi_kind (&x->ts));
995 }
996
997
998 void
999 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
1000 {
1001 f->ts.type = BT_INTEGER;
1002 f->ts.kind = gfc_default_integer_kind;
1003 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
1004 }
1005
1006
1007 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1008
1009 void
1010 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
1011 {
1012 gfc_symbol *vtab;
1013 gfc_symtree *st;
1014
1015 /* Prevent double resolution. */
1016 if (f->ts.type == BT_LOGICAL)
1017 return;
1018
1019 /* Replace the first argument with the corresponding vtab. */
1020 if (a->ts.type == BT_CLASS)
1021 gfc_add_vptr_component (a);
1022 else if (a->ts.type == BT_DERIVED)
1023 {
1024 locus where;
1025
1026 vtab = gfc_find_derived_vtab (a->ts.u.derived);
1027 /* Clear the old expr. */
1028 gfc_free_ref_list (a->ref);
1029 where = a->where;
1030 memset (a, '\0', sizeof (gfc_expr));
1031 /* Construct a new one. */
1032 a->expr_type = EXPR_VARIABLE;
1033 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1034 a->symtree = st;
1035 a->ts = vtab->ts;
1036 a->where = where;
1037 }
1038
1039 /* Replace the second argument with the corresponding vtab. */
1040 if (mo->ts.type == BT_CLASS)
1041 gfc_add_vptr_component (mo);
1042 else if (mo->ts.type == BT_DERIVED)
1043 {
1044 locus where;
1045
1046 vtab = gfc_find_derived_vtab (mo->ts.u.derived);
1047 /* Clear the old expr. */
1048 where = mo->where;
1049 gfc_free_ref_list (mo->ref);
1050 memset (mo, '\0', sizeof (gfc_expr));
1051 /* Construct a new one. */
1052 mo->expr_type = EXPR_VARIABLE;
1053 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1054 mo->symtree = st;
1055 mo->ts = vtab->ts;
1056 mo->where = where;
1057 }
1058
1059 f->ts.type = BT_LOGICAL;
1060 f->ts.kind = 4;
1061
1062 f->value.function.isym->formal->ts = a->ts;
1063 f->value.function.isym->formal->next->ts = mo->ts;
1064
1065 /* Call library function. */
1066 f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
1067 }
1068
1069
1070 void
1071 gfc_resolve_fdate (gfc_expr *f)
1072 {
1073 f->ts.type = BT_CHARACTER;
1074 f->ts.kind = gfc_default_character_kind;
1075 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
1076 }
1077
1078
1079 void
1080 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1081 {
1082 f->ts.type = BT_INTEGER;
1083 f->ts.kind = (kind == NULL)
1084 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1085 f->value.function.name
1086 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
1087 gfc_type_letter (a->ts.type),
1088 gfc_type_abi_kind (&a->ts));
1089 }
1090
1091
1092 void
1093 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1094 {
1095 f->ts.type = BT_INTEGER;
1096 f->ts.kind = gfc_default_integer_kind;
1097 if (n->ts.kind != f->ts.kind)
1098 gfc_convert_type (n, &f->ts, 2);
1099 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1100 }
1101
1102
1103 void
1104 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1105 {
1106 f->ts = x->ts;
1107 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
1108 }
1109
1110
1111 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1112
1113 void
1114 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1115 {
1116 f->ts = x->ts;
1117 f->value.function.name = gfc_get_string ("<intrinsic>");
1118 }
1119
1120
1121 void
1122 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1123 {
1124 f->ts = x->ts;
1125 f->value.function.name
1126 = gfc_get_string ("__tgamma_%d", x->ts.kind);
1127 }
1128
1129
1130 void
1131 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1132 {
1133 f->ts.type = BT_INTEGER;
1134 f->ts.kind = 4;
1135 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1136 }
1137
1138
1139 void
1140 gfc_resolve_getgid (gfc_expr *f)
1141 {
1142 f->ts.type = BT_INTEGER;
1143 f->ts.kind = 4;
1144 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1145 }
1146
1147
1148 void
1149 gfc_resolve_getpid (gfc_expr *f)
1150 {
1151 f->ts.type = BT_INTEGER;
1152 f->ts.kind = 4;
1153 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1154 }
1155
1156
1157 void
1158 gfc_resolve_getuid (gfc_expr *f)
1159 {
1160 f->ts.type = BT_INTEGER;
1161 f->ts.kind = 4;
1162 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1163 }
1164
1165
1166 void
1167 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1168 {
1169 f->ts.type = BT_INTEGER;
1170 f->ts.kind = 4;
1171 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1172 }
1173
1174
1175 void
1176 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1177 {
1178 f->ts = x->ts;
1179 f->value.function.name = gfc_get_string ("__hypot_r%d",
1180 gfc_type_abi_kind (&x->ts));
1181 }
1182
1183
1184 void
1185 gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1186 {
1187 resolve_transformational ("iall", f, array, dim, mask);
1188 }
1189
1190
1191 void
1192 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1193 {
1194 /* If the kind of i and j are different, then g77 cross-promoted the
1195 kinds to the largest value. The Fortran 95 standard requires the
1196 kinds to match. */
1197
1198 if (i->ts.kind != j->ts.kind)
1199 {
1200 if (i->ts.kind == gfc_kind_max (i, j))
1201 gfc_convert_type (j, &i->ts, 2);
1202 else
1203 gfc_convert_type (i, &j->ts, 2);
1204 }
1205
1206 f->ts = i->ts;
1207 const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_m_%d" : "__iand_%d";
1208 f->value.function.name = gfc_get_string (name, i->ts.kind);
1209 }
1210
1211
1212 void
1213 gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1214 {
1215 resolve_transformational ("iany", f, array, dim, mask);
1216 }
1217
1218
1219 void
1220 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1221 {
1222 f->ts = i->ts;
1223 const char *name = i->ts.kind == BT_UNSIGNED ? "__ibclr_m_%d" : "__ibclr_%d";
1224 f->value.function.name = gfc_get_string (name, i->ts.kind);
1225 }
1226
1227
1228 void
1229 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1230 gfc_expr *len ATTRIBUTE_UNUSED)
1231 {
1232 f->ts = i->ts;
1233 const char *name = i->ts.kind == BT_UNSIGNED ? "__ibits_m_%d" : "__ibits_%d";
1234 f->value.function.name = gfc_get_string (name, i->ts.kind);
1235 }
1236
1237
1238 void
1239 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1240 {
1241 f->ts = i->ts;
1242 const char *name = i->ts.kind == BT_UNSIGNED ? "__ibset_m_%d" : "__ibset_%d";
1243 f->value.function.name = gfc_get_string (name, i->ts.kind);
1244 }
1245
1246
1247 void
1248 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1249 {
1250 f->ts.type = BT_INTEGER;
1251 if (kind)
1252 f->ts.kind = mpz_get_si (kind->value.integer);
1253 else
1254 f->ts.kind = gfc_default_integer_kind;
1255 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1256 }
1257
1258
1259 void
1260 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1261 {
1262 f->ts.type = BT_INTEGER;
1263 if (kind)
1264 f->ts.kind = mpz_get_si (kind->value.integer);
1265 else
1266 f->ts.kind = gfc_default_integer_kind;
1267 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1268 }
1269
1270
1271 void
1272 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1273 {
1274 gfc_resolve_nint (f, a, NULL);
1275 }
1276
1277
1278 void
1279 gfc_resolve_ierrno (gfc_expr *f)
1280 {
1281 f->ts.type = BT_INTEGER;
1282 f->ts.kind = gfc_default_integer_kind;
1283 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1284 }
1285
1286
1287 void
1288 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1289 {
1290 /* If the kind of i and j are different, then g77 cross-promoted the
1291 kinds to the largest value. The Fortran 95 standard requires the
1292 kinds to match. */
1293
1294 if (i->ts.kind != j->ts.kind)
1295 {
1296 if (i->ts.kind == gfc_kind_max (i, j))
1297 gfc_convert_type (j, &i->ts, 2);
1298 else
1299 gfc_convert_type (i, &j->ts, 2);
1300 }
1301
1302 const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_m_%d" : "__ieor_%d";
1303 f->ts = i->ts;
1304 f->value.function.name = gfc_get_string (name, i->ts.kind);
1305 }
1306
1307
1308 void
1309 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1310 {
1311 /* If the kind of i and j are different, then g77 cross-promoted the
1312 kinds to the largest value. The Fortran 95 standard requires the
1313 kinds to match. */
1314
1315 if (i->ts.kind != j->ts.kind)
1316 {
1317 if (i->ts.kind == gfc_kind_max (i, j))
1318 gfc_convert_type (j, &i->ts, 2);
1319 else
1320 gfc_convert_type (i, &j->ts, 2);
1321 }
1322
1323 const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_m_%d" : "__ior_%d";
1324 f->ts = i->ts;
1325 f->value.function.name = gfc_get_string (name, i->ts.kind);
1326 }
1327
1328
1329 void
1330 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1331 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1332 gfc_expr *kind)
1333 {
1334 gfc_typespec ts;
1335 gfc_clear_ts (&ts);
1336
1337 f->ts.type = BT_INTEGER;
1338 if (kind)
1339 f->ts.kind = mpz_get_si (kind->value.integer);
1340 else
1341 f->ts.kind = gfc_default_integer_kind;
1342
1343 if (back && back->ts.kind != gfc_default_integer_kind)
1344 {
1345 ts.type = BT_LOGICAL;
1346 ts.kind = gfc_default_integer_kind;
1347 ts.u.derived = NULL;
1348 ts.u.cl = NULL;
1349 gfc_convert_type (back, &ts, 2);
1350 }
1351
1352 f->value.function.name
1353 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1354 }
1355
1356
1357 void
1358 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1359 {
1360 f->ts.type = BT_INTEGER;
1361 f->ts.kind = (kind == NULL)
1362 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1363 f->value.function.name
1364 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1365 gfc_type_letter (a->ts.type),
1366 gfc_type_abi_kind (&a->ts));
1367 }
1368
1369 void
1370 gfc_resolve_uint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1371 {
1372 f->ts.type = BT_UNSIGNED;
1373 f->ts.kind = (kind == NULL)
1374 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1375 f->value.function.name
1376 = gfc_get_string ("__uint_%d_%c%d", f->ts.kind,
1377 gfc_type_letter (a->ts.type),
1378 gfc_type_abi_kind (&a->ts));
1379 }
1380
1381
1382 void
1383 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1384 {
1385 f->ts.type = BT_INTEGER;
1386 f->ts.kind = 2;
1387 f->value.function.name
1388 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1389 gfc_type_letter (a->ts.type),
1390 gfc_type_abi_kind (&a->ts));
1391 }
1392
1393
1394 void
1395 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1396 {
1397 f->ts.type = BT_INTEGER;
1398 f->ts.kind = 8;
1399 f->value.function.name
1400 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1401 gfc_type_letter (a->ts.type),
1402 gfc_type_abi_kind (&a->ts));
1403 }
1404
1405
1406 void
1407 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1408 {
1409 f->ts.type = BT_INTEGER;
1410 f->ts.kind = 4;
1411 f->value.function.name
1412 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1413 gfc_type_letter (a->ts.type),
1414 gfc_type_abi_kind (&a->ts));
1415 }
1416
1417
1418 void
1419 gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1420 {
1421 resolve_transformational ("iparity", f, array, dim, mask);
1422 }
1423
1424
1425 void
1426 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1427 {
1428 gfc_typespec ts;
1429 gfc_clear_ts (&ts);
1430
1431 f->ts.type = BT_LOGICAL;
1432 f->ts.kind = gfc_default_integer_kind;
1433 if (u->ts.kind != gfc_c_int_kind)
1434 {
1435 ts.type = BT_INTEGER;
1436 ts.kind = gfc_c_int_kind;
1437 ts.u.derived = NULL;
1438 ts.u.cl = NULL;
1439 gfc_convert_type (u, &ts, 2);
1440 }
1441
1442 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1443 }
1444
1445
1446 void
1447 gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
1448 {
1449 f->ts.type = BT_LOGICAL;
1450 f->ts.kind = gfc_default_logical_kind;
1451 f->value.function.name = gfc_get_string ("__is_contiguous");
1452 }
1453
1454
1455 void
1456 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1457 {
1458 f->ts = i->ts;
1459 f->value.function.name
1460 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1461 }
1462
1463
1464 void
1465 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1466 {
1467 f->ts = i->ts;
1468 f->value.function.name
1469 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1470 }
1471
1472
1473 void
1474 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1475 {
1476 f->ts = i->ts;
1477 f->value.function.name
1478 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1479 }
1480
1481
1482 void
1483 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1484 {
1485 int s_kind;
1486
1487 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1488
1489 f->ts = i->ts;
1490 f->value.function.name
1491 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1492 }
1493
1494
1495 void
1496 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1497 {
1498 resolve_bound (f, array, dim, kind, "__lbound", false);
1499 }
1500
1501
1502 void
1503 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1504 {
1505 resolve_bound (f, array, dim, kind, "__lcobound", true);
1506 }
1507
1508
1509 void
1510 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1511 {
1512 f->ts.type = BT_INTEGER;
1513 if (kind)
1514 f->ts.kind = mpz_get_si (kind->value.integer);
1515 else
1516 f->ts.kind = gfc_default_integer_kind;
1517 f->value.function.name
1518 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1519 gfc_default_integer_kind);
1520 }
1521
1522
1523 void
1524 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1525 {
1526 f->ts.type = BT_INTEGER;
1527 if (kind)
1528 f->ts.kind = mpz_get_si (kind->value.integer);
1529 else
1530 f->ts.kind = gfc_default_integer_kind;
1531 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1532 }
1533
1534
1535 void
1536 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1537 {
1538 f->ts = x->ts;
1539 f->value.function.name
1540 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1541 }
1542
1543
1544 void
1545 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1546 gfc_expr *p2 ATTRIBUTE_UNUSED)
1547 {
1548 f->ts.type = BT_INTEGER;
1549 f->ts.kind = gfc_default_integer_kind;
1550 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1551 }
1552
1553
1554 void
1555 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1556 {
1557 f->ts.type= BT_INTEGER;
1558 f->ts.kind = gfc_index_integer_kind;
1559 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1560 }
1561
1562
1563 void
1564 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1565 {
1566 f->ts = x->ts;
1567 f->value.function.name
1568 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type),
1569 gfc_type_abi_kind (&x->ts));
1570 }
1571
1572
1573 void
1574 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1575 {
1576 f->ts = x->ts;
1577 f->value.function.name
1578 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1579 gfc_type_abi_kind (&x->ts));
1580 }
1581
1582
1583 void
1584 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1585 {
1586 f->ts.type = BT_LOGICAL;
1587 f->ts.kind = (kind == NULL)
1588 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1589 f->rank = a->rank;
1590 f->corank = a->corank;
1591
1592 f->value.function.name
1593 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1594 gfc_type_letter (a->ts.type),
1595 gfc_type_abi_kind (&a->ts));
1596 }
1597
1598
1599 void
1600 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1601 {
1602 gfc_expr temp;
1603
1604 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1605 {
1606 f->ts.type = BT_LOGICAL;
1607 f->ts.kind = gfc_default_logical_kind;
1608 }
1609 else
1610 {
1611 temp.expr_type = EXPR_OP;
1612 gfc_clear_ts (&temp.ts);
1613 temp.value.op.op = INTRINSIC_NONE;
1614 temp.value.op.op1 = a;
1615 temp.value.op.op2 = b;
1616 gfc_type_convert_binary (&temp, 1);
1617 f->ts = temp.ts;
1618 }
1619
1620 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1621 f->corank = a->corank;
1622
1623 if (a->rank == 2 && b->rank == 2)
1624 {
1625 if (a->shape && b->shape)
1626 {
1627 f->shape = gfc_get_shape (f->rank);
1628 mpz_init_set (f->shape[0], a->shape[0]);
1629 mpz_init_set (f->shape[1], b->shape[1]);
1630 }
1631 }
1632 else if (a->rank == 1)
1633 {
1634 if (b->shape)
1635 {
1636 f->shape = gfc_get_shape (f->rank);
1637 mpz_init_set (f->shape[0], b->shape[1]);
1638 }
1639 }
1640 else
1641 {
1642 /* b->rank == 1 and a->rank == 2 here, all other cases have
1643 been caught in check.cc. */
1644 if (a->shape)
1645 {
1646 f->shape = gfc_get_shape (f->rank);
1647 mpz_init_set (f->shape[0], a->shape[0]);
1648 }
1649 }
1650
1651 f->value.function.name
1652 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1653 gfc_type_abi_kind (&f->ts));
1654 }
1655
1656
1657 static void
1658 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1659 {
1660 gfc_actual_arglist *a;
1661
1662 f->ts.type = args->expr->ts.type;
1663 f->ts.kind = args->expr->ts.kind;
1664 /* Find the largest type kind. */
1665 for (a = args->next; a; a = a->next)
1666 {
1667 if (a->expr->ts.kind > f->ts.kind)
1668 f->ts.kind = a->expr->ts.kind;
1669 }
1670
1671 /* Convert all parameters to the required kind. */
1672 for (a = args; a; a = a->next)
1673 {
1674 if (a->expr->ts.kind != f->ts.kind)
1675 gfc_convert_type (a->expr, &f->ts, 2);
1676 }
1677
1678 f->value.function.name
1679 = gfc_get_string (name, gfc_type_letter (f->ts.type),
1680 gfc_type_abi_kind (&f->ts));
1681 }
1682
1683
1684 void
1685 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1686 {
1687 gfc_resolve_minmax ("__max_%c%d", f, args);
1688 }
1689
1690 /* The smallest kind for which a minloc and maxloc implementation exists. */
1691
1692 #define MINMAXLOC_MIN_KIND 4
1693
1694 void
1695 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1696 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1697 {
1698 const char *name;
1699 int i, j, idim;
1700 int fkind;
1701 int d_num;
1702
1703 f->ts.type = BT_INTEGER;
1704
1705 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1706 we do a type conversion further down. */
1707 if (kind)
1708 fkind = mpz_get_si (kind->value.integer);
1709 else
1710 fkind = gfc_default_integer_kind;
1711
1712 if (fkind < MINMAXLOC_MIN_KIND)
1713 f->ts.kind = MINMAXLOC_MIN_KIND;
1714 else
1715 f->ts.kind = fkind;
1716
1717 if (dim == NULL)
1718 {
1719 f->rank = 1;
1720 f->shape = gfc_get_shape (1);
1721 mpz_init_set_si (f->shape[0], array->rank);
1722 }
1723 else
1724 {
1725 f->rank = array->rank - 1;
1726 gfc_resolve_dim_arg (dim);
1727 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1728 {
1729 idim = (int) mpz_get_si (dim->value.integer);
1730 f->shape = gfc_get_shape (f->rank);
1731 for (i = 0, j = 0; i < f->rank; i++, j++)
1732 {
1733 if (i == (idim - 1))
1734 j++;
1735 mpz_init_set (f->shape[i], array->shape[j]);
1736 }
1737 }
1738 }
1739
1740 if (mask)
1741 {
1742 if (mask->rank == 0)
1743 name = "smaxloc";
1744 else
1745 name = "mmaxloc";
1746
1747 resolve_mask_arg (mask);
1748 }
1749 else
1750 name = "maxloc";
1751
1752 if (dim)
1753 {
1754 if (array->ts.type != BT_CHARACTER || f->rank != 0)
1755 d_num = 1;
1756 else
1757 d_num = 2;
1758 }
1759 else
1760 d_num = 0;
1761
1762 f->value.function.name
1763 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1764 gfc_type_letter (array->ts.type),
1765 gfc_type_abi_kind (&array->ts));
1766
1767 if (kind)
1768 fkind = mpz_get_si (kind->value.integer);
1769 else
1770 fkind = gfc_default_integer_kind;
1771
1772 if (fkind != f->ts.kind)
1773 {
1774 gfc_typespec ts;
1775 gfc_clear_ts (&ts);
1776
1777 ts.type = BT_INTEGER;
1778 ts.kind = fkind;
1779 gfc_convert_type_warn (f, &ts, 2, 0);
1780 }
1781
1782 if (back->ts.kind != gfc_logical_4_kind)
1783 {
1784 gfc_typespec ts;
1785 gfc_clear_ts (&ts);
1786 ts.type = BT_LOGICAL;
1787 ts.kind = gfc_logical_4_kind;
1788 gfc_convert_type_warn (back, &ts, 2, 0);
1789 }
1790 }
1791
1792
1793 void
1794 gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
1795 gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
1796 gfc_expr *back)
1797 {
1798 const char *name;
1799 int i, j, idim;
1800 int fkind;
1801 int d_num;
1802
1803 /* See at the end of the function for why this is necessary. */
1804
1805 if (f->do_not_resolve_again)
1806 return;
1807
1808 f->ts.type = BT_INTEGER;
1809
1810 /* We have a single library version, which uses index_type. */
1811
1812 if (kind)
1813 fkind = mpz_get_si (kind->value.integer);
1814 else
1815 fkind = gfc_default_integer_kind;
1816
1817 f->ts.kind = gfc_index_integer_kind;
1818
1819 /* Convert value. If array is not LOGICAL and value is, we already
1820 issued an error earlier. */
1821
1822 if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
1823 || array->ts.kind != value->ts.kind)
1824 gfc_convert_type_warn (value, &array->ts, 2, 0);
1825
1826 if (dim == NULL)
1827 {
1828 f->rank = 1;
1829 f->shape = gfc_get_shape (1);
1830 mpz_init_set_si (f->shape[0], array->rank);
1831 }
1832 else
1833 {
1834 f->rank = array->rank - 1;
1835 gfc_resolve_dim_arg (dim);
1836 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1837 {
1838 idim = (int) mpz_get_si (dim->value.integer);
1839 f->shape = gfc_get_shape (f->rank);
1840 for (i = 0, j = 0; i < f->rank; i++, j++)
1841 {
1842 if (i == (idim - 1))
1843 j++;
1844 mpz_init_set (f->shape[i], array->shape[j]);
1845 }
1846 }
1847 }
1848
1849 if (mask)
1850 {
1851 if (mask->rank == 0)
1852 name = "sfindloc";
1853 else
1854 name = "mfindloc";
1855
1856 resolve_mask_arg (mask);
1857 }
1858 else
1859 name = "findloc";
1860
1861 if (dim)
1862 {
1863 if (f->rank > 0)
1864 d_num = 1;
1865 else
1866 d_num = 2;
1867 }
1868 else
1869 d_num = 0;
1870
1871 if (back->ts.kind != gfc_logical_4_kind)
1872 {
1873 gfc_typespec ts;
1874 gfc_clear_ts (&ts);
1875 ts.type = BT_LOGICAL;
1876 ts.kind = gfc_logical_4_kind;
1877 gfc_convert_type_warn (back, &ts, 2, 0);
1878 }
1879
1880 f->value.function.name
1881 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1882 gfc_type_letter (array->ts.type, true),
1883 gfc_type_abi_kind (&array->ts));
1884
1885 /* We only have a single library function, so we need to convert
1886 here. If the function is resolved from within a convert
1887 function generated on a previous round of resolution, endless
1888 recursion could occur. Guard against that here. */
1889
1890 if (f->ts.kind != fkind)
1891 {
1892 f->do_not_resolve_again = 1;
1893 gfc_typespec ts;
1894 gfc_clear_ts (&ts);
1895
1896 ts.type = BT_INTEGER;
1897 ts.kind = fkind;
1898 gfc_convert_type_warn (f, &ts, 2, 0);
1899 }
1900
1901 }
1902
1903 void
1904 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1905 gfc_expr *mask)
1906 {
1907 const char *name;
1908 int i, j, idim;
1909
1910 f->ts = array->ts;
1911
1912 if (dim != NULL)
1913 {
1914 f->rank = array->rank - 1;
1915 gfc_resolve_dim_arg (dim);
1916
1917 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1918 {
1919 idim = (int) mpz_get_si (dim->value.integer);
1920 f->shape = gfc_get_shape (f->rank);
1921 for (i = 0, j = 0; i < f->rank; i++, j++)
1922 {
1923 if (i == (idim - 1))
1924 j++;
1925 mpz_init_set (f->shape[i], array->shape[j]);
1926 }
1927 }
1928 }
1929
1930 if (mask)
1931 {
1932 if (mask->rank == 0)
1933 name = "smaxval";
1934 else
1935 name = "mmaxval";
1936
1937 resolve_mask_arg (mask);
1938 }
1939 else
1940 name = "maxval";
1941
1942 if (array->ts.type != BT_CHARACTER)
1943 f->value.function.name
1944 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1945 gfc_type_letter (array->ts.type),
1946 gfc_type_abi_kind (&array->ts));
1947 else
1948 f->value.function.name
1949 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1950 gfc_type_letter (array->ts.type),
1951 gfc_type_abi_kind (&array->ts));
1952 }
1953
1954
1955 void
1956 gfc_resolve_mclock (gfc_expr *f)
1957 {
1958 f->ts.type = BT_INTEGER;
1959 f->ts.kind = 4;
1960 f->value.function.name = PREFIX ("mclock");
1961 }
1962
1963
1964 void
1965 gfc_resolve_mclock8 (gfc_expr *f)
1966 {
1967 f->ts.type = BT_INTEGER;
1968 f->ts.kind = 8;
1969 f->value.function.name = PREFIX ("mclock8");
1970 }
1971
1972
1973 void
1974 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1975 gfc_expr *kind)
1976 {
1977 f->ts.type = BT_INTEGER;
1978 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1979 : gfc_default_integer_kind;
1980
1981 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1982 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1983 else
1984 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1985 }
1986
1987
1988 void
1989 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1990 gfc_expr *fsource ATTRIBUTE_UNUSED,
1991 gfc_expr *mask ATTRIBUTE_UNUSED)
1992 {
1993 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1994 gfc_resolve_substring_charlen (tsource);
1995
1996 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1997 gfc_resolve_substring_charlen (fsource);
1998
1999 if (tsource->ts.type == BT_CHARACTER)
2000 check_charlen_present (tsource);
2001
2002 f->ts = tsource->ts;
2003 f->value.function.name
2004 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
2005 gfc_type_abi_kind (&tsource->ts));
2006 }
2007
2008
2009 void
2010 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
2011 gfc_expr *j ATTRIBUTE_UNUSED,
2012 gfc_expr *mask ATTRIBUTE_UNUSED)
2013 {
2014 f->ts = i->ts;
2015
2016 f->value.function.name
2017 = gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i->ts.type),
2018 i->ts.kind);
2019 }
2020
2021
2022 void
2023 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
2024 {
2025 gfc_resolve_minmax ("__min_%c%d", f, args);
2026 }
2027
2028
2029 void
2030 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2031 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
2032 {
2033 const char *name;
2034 int i, j, idim;
2035 int fkind;
2036 int d_num;
2037
2038 f->ts.type = BT_INTEGER;
2039
2040 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2041 we do a type conversion further down. */
2042 if (kind)
2043 fkind = mpz_get_si (kind->value.integer);
2044 else
2045 fkind = gfc_default_integer_kind;
2046
2047 if (fkind < MINMAXLOC_MIN_KIND)
2048 f->ts.kind = MINMAXLOC_MIN_KIND;
2049 else
2050 f->ts.kind = fkind;
2051
2052 if (dim == NULL)
2053 {
2054 f->rank = 1;
2055 f->shape = gfc_get_shape (1);
2056 mpz_init_set_si (f->shape[0], array->rank);
2057 }
2058 else
2059 {
2060 f->rank = array->rank - 1;
2061 gfc_resolve_dim_arg (dim);
2062 if (array->shape && dim->expr_type == EXPR_CONSTANT)
2063 {
2064 idim = (int) mpz_get_si (dim->value.integer);
2065 f->shape = gfc_get_shape (f->rank);
2066 for (i = 0, j = 0; i < f->rank; i++, j++)
2067 {
2068 if (i == (idim - 1))
2069 j++;
2070 mpz_init_set (f->shape[i], array->shape[j]);
2071 }
2072 }
2073 }
2074
2075 if (mask)
2076 {
2077 if (mask->rank == 0)
2078 name = "sminloc";
2079 else
2080 name = "mminloc";
2081
2082 resolve_mask_arg (mask);
2083 }
2084 else
2085 name = "minloc";
2086
2087 if (dim)
2088 {
2089 if (array->ts.type != BT_CHARACTER || f->rank != 0)
2090 d_num = 1;
2091 else
2092 d_num = 2;
2093 }
2094 else
2095 d_num = 0;
2096
2097 f->value.function.name
2098 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2099 gfc_type_letter (array->ts.type),
2100 gfc_type_abi_kind (&array->ts));
2101
2102 if (fkind != f->ts.kind)
2103 {
2104 gfc_typespec ts;
2105 gfc_clear_ts (&ts);
2106
2107 ts.type = BT_INTEGER;
2108 ts.kind = fkind;
2109 gfc_convert_type_warn (f, &ts, 2, 0);
2110 }
2111
2112 if (back->ts.kind != gfc_logical_4_kind)
2113 {
2114 gfc_typespec ts;
2115 gfc_clear_ts (&ts);
2116 ts.type = BT_LOGICAL;
2117 ts.kind = gfc_logical_4_kind;
2118 gfc_convert_type_warn (back, &ts, 2, 0);
2119 }
2120 }
2121
2122
2123 void
2124 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2125 gfc_expr *mask)
2126 {
2127 const char *name;
2128 int i, j, idim;
2129
2130 f->ts = array->ts;
2131
2132 if (dim != NULL)
2133 {
2134 f->rank = array->rank - 1;
2135 gfc_resolve_dim_arg (dim);
2136
2137 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2138 {
2139 idim = (int) mpz_get_si (dim->value.integer);
2140 f->shape = gfc_get_shape (f->rank);
2141 for (i = 0, j = 0; i < f->rank; i++, j++)
2142 {
2143 if (i == (idim - 1))
2144 j++;
2145 mpz_init_set (f->shape[i], array->shape[j]);
2146 }
2147 }
2148 }
2149
2150 if (mask)
2151 {
2152 if (mask->rank == 0)
2153 name = "sminval";
2154 else
2155 name = "mminval";
2156
2157 resolve_mask_arg (mask);
2158 }
2159 else
2160 name = "minval";
2161
2162 if (array->ts.type != BT_CHARACTER)
2163 f->value.function.name
2164 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2165 gfc_type_letter (array->ts.type),
2166 gfc_type_abi_kind (&array->ts));
2167 else
2168 f->value.function.name
2169 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2170 gfc_type_letter (array->ts.type),
2171 gfc_type_abi_kind (&array->ts));
2172 }
2173
2174
2175 void
2176 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2177 {
2178 f->ts.type = a->ts.type;
2179 if (p != NULL)
2180 f->ts.kind = gfc_kind_max (a,p);
2181 else
2182 f->ts.kind = a->ts.kind;
2183
2184 if (p != NULL && a->ts.kind != p->ts.kind)
2185 {
2186 if (a->ts.kind == gfc_kind_max (a,p))
2187 gfc_convert_type (p, &a->ts, 2);
2188 else
2189 gfc_convert_type (a, &p->ts, 2);
2190 }
2191
2192 f->value.function.name
2193 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2194 gfc_type_abi_kind (&f->ts));
2195 }
2196
2197
2198 void
2199 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2200 {
2201 f->ts.type = a->ts.type;
2202 if (p != NULL)
2203 f->ts.kind = gfc_kind_max (a,p);
2204 else
2205 f->ts.kind = a->ts.kind;
2206
2207 if (p != NULL && a->ts.kind != p->ts.kind)
2208 {
2209 if (a->ts.kind == gfc_kind_max (a,p))
2210 gfc_convert_type (p, &a->ts, 2);
2211 else
2212 gfc_convert_type (a, &p->ts, 2);
2213 }
2214
2215 f->value.function.name
2216 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2217 gfc_type_abi_kind (&f->ts));
2218 }
2219
2220 void
2221 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2222 {
2223 if (p->ts.kind != a->ts.kind)
2224 gfc_convert_type (p, &a->ts, 2);
2225
2226 f->ts = a->ts;
2227 f->value.function.name
2228 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2229 gfc_type_abi_kind (&a->ts));
2230 }
2231
2232 void
2233 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2234 {
2235 f->ts.type = BT_INTEGER;
2236 f->ts.kind = (kind == NULL)
2237 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2238 f->value.function.name
2239 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2240 }
2241
2242
2243 void
2244 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2245 {
2246 resolve_transformational ("norm2", f, array, dim, NULL);
2247 }
2248
2249
2250 void
2251 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2252 {
2253 f->ts = i->ts;
2254 const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d";
2255 f->value.function.name = gfc_get_string (name, i->ts.kind);
2256 }
2257
2258
2259 void
2260 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2261 {
2262 f->ts.type = i->ts.type;
2263 f->ts.kind = gfc_kind_max (i, j);
2264
2265 if (i->ts.kind != j->ts.kind)
2266 {
2267 if (i->ts.kind == gfc_kind_max (i, j))
2268 gfc_convert_type (j, &i->ts, 2);
2269 else
2270 gfc_convert_type (i, &j->ts, 2);
2271 }
2272
2273 f->value.function.name
2274 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type),
2275 gfc_type_abi_kind (&f->ts));
2276 }
2277
2278
2279 void
2280 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2281 gfc_expr *vector ATTRIBUTE_UNUSED)
2282 {
2283 if (array->ts.type == BT_CHARACTER && array->ref)
2284 gfc_resolve_substring_charlen (array);
2285
2286 f->ts = array->ts;
2287 f->rank = 1;
2288
2289 resolve_mask_arg (mask);
2290
2291 if (mask->rank != 0)
2292 {
2293 if (array->ts.type == BT_CHARACTER)
2294 f->value.function.name
2295 = array->ts.kind == 1 ? PREFIX ("pack_char")
2296 : gfc_get_string
2297 (PREFIX ("pack_char%d"),
2298 array->ts.kind);
2299 else
2300 f->value.function.name = PREFIX ("pack");
2301 }
2302 else
2303 {
2304 if (array->ts.type == BT_CHARACTER)
2305 f->value.function.name
2306 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2307 : gfc_get_string
2308 (PREFIX ("pack_s_char%d"),
2309 array->ts.kind);
2310 else
2311 f->value.function.name = PREFIX ("pack_s");
2312 }
2313 }
2314
2315
2316 void
2317 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2318 {
2319 resolve_transformational ("parity", f, array, dim, NULL);
2320 }
2321
2322
2323 void
2324 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2325 gfc_expr *mask)
2326 {
2327 resolve_transformational ("product", f, array, dim, mask);
2328 }
2329
2330
2331 void
2332 gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2333 {
2334 f->ts.type = BT_INTEGER;
2335 f->ts.kind = gfc_default_integer_kind;
2336 f->value.function.name = gfc_get_string ("__rank");
2337 }
2338
2339
2340 void
2341 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2342 {
2343 f->ts.type = BT_REAL;
2344
2345 if (kind != NULL)
2346 f->ts.kind = mpz_get_si (kind->value.integer);
2347 else
2348 f->ts.kind = (a->ts.type == BT_COMPLEX)
2349 ? a->ts.kind : gfc_default_real_kind;
2350
2351 f->value.function.name
2352 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2353 gfc_type_letter (a->ts.type),
2354 gfc_type_abi_kind (&a->ts));
2355 }
2356
2357
2358 void
2359 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2360 {
2361 f->ts.type = BT_REAL;
2362 f->ts.kind = a->ts.kind;
2363 f->value.function.name
2364 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2365 gfc_type_letter (a->ts.type),
2366 gfc_type_abi_kind (&a->ts));
2367 }
2368
2369
2370 void
2371 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2372 gfc_expr *p2 ATTRIBUTE_UNUSED)
2373 {
2374 f->ts.type = BT_INTEGER;
2375 f->ts.kind = gfc_default_integer_kind;
2376 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2377 }
2378
2379
2380 void
2381 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2382 gfc_expr *ncopies)
2383 {
2384 gfc_expr *tmp;
2385 f->ts.type = BT_CHARACTER;
2386 f->ts.kind = string->ts.kind;
2387 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2388
2389 /* If possible, generate a character length. */
2390 if (f->ts.u.cl == NULL)
2391 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2392
2393 tmp = NULL;
2394 if (string->expr_type == EXPR_CONSTANT)
2395 {
2396 tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2397 string->value.character.length);
2398 }
2399 else if (string->ts.u.cl && string->ts.u.cl->length)
2400 {
2401 tmp = gfc_copy_expr (string->ts.u.cl->length);
2402 }
2403
2404 if (tmp)
2405 {
2406 /* Force-convert to gfc_charlen_int_kind before gfc_multiply. */
2407 gfc_expr *e = gfc_copy_expr (ncopies);
2408 gfc_typespec ts = tmp->ts;
2409 ts.kind = gfc_charlen_int_kind;
2410 gfc_convert_type_warn (e, &ts, 2, 0);
2411 gfc_convert_type_warn (tmp, &ts, 2, 0);
2412 f->ts.u.cl->length = gfc_multiply (tmp, e);
2413 }
2414 }
2415
2416
2417 void
2418 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2419 gfc_expr *pad ATTRIBUTE_UNUSED,
2420 gfc_expr *order ATTRIBUTE_UNUSED)
2421 {
2422 mpz_t rank;
2423 int kind;
2424 int i;
2425
2426 if (source->ts.type == BT_CHARACTER && source->ref)
2427 gfc_resolve_substring_charlen (source);
2428
2429 f->ts = source->ts;
2430
2431 gfc_array_size (shape, &rank);
2432 f->rank = mpz_get_si (rank);
2433 mpz_clear (rank);
2434 switch (source->ts.type)
2435 {
2436 case BT_COMPLEX:
2437 case BT_REAL:
2438 case BT_INTEGER:
2439 case BT_LOGICAL:
2440 case BT_CHARACTER:
2441 kind = source->ts.kind;
2442 break;
2443
2444 default:
2445 kind = 0;
2446 break;
2447 }
2448
2449 switch (kind)
2450 {
2451 case 4:
2452 case 8:
2453 case 10:
2454 case 16:
2455 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2456 f->value.function.name
2457 = gfc_get_string (PREFIX ("reshape_%c%d"),
2458 gfc_type_letter (source->ts.type),
2459 gfc_type_abi_kind (&source->ts));
2460 else if (source->ts.type == BT_CHARACTER)
2461 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2462 kind);
2463 else
2464 f->value.function.name
2465 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2466 break;
2467
2468 default:
2469 f->value.function.name = (source->ts.type == BT_CHARACTER
2470 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2471 break;
2472 }
2473
2474 if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2475 {
2476 gfc_constructor *c;
2477 f->shape = gfc_get_shape (f->rank);
2478 c = gfc_constructor_first (shape->value.constructor);
2479 for (i = 0; i < f->rank; i++)
2480 {
2481 mpz_init_set (f->shape[i], c->expr->value.integer);
2482 c = gfc_constructor_next (c);
2483 }
2484 }
2485
2486 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2487 so many runtime variations. */
2488 if (shape->ts.kind != gfc_index_integer_kind)
2489 {
2490 gfc_typespec ts = shape->ts;
2491 ts.kind = gfc_index_integer_kind;
2492 gfc_convert_type_warn (shape, &ts, 2, 0);
2493 }
2494 if (order && order->ts.kind != gfc_index_integer_kind)
2495 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2496 }
2497
2498
2499 void
2500 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2501 {
2502 f->ts = x->ts;
2503 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2504 }
2505
2506 void
2507 gfc_resolve_fe_runtime_error (gfc_code *c)
2508 {
2509 const char *name;
2510 gfc_actual_arglist *a;
2511
2512 name = gfc_get_string (PREFIX ("runtime_error"));
2513
2514 for (a = c->ext.actual->next; a; a = a->next)
2515 a->name = "%VAL";
2516
2517 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2518 /* We set the backend_decl here because runtime_error is a
2519 variadic function and we would use the wrong calling
2520 convention otherwise. */
2521 c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2522 }
2523
2524 void
2525 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2526 {
2527 f->ts = x->ts;
2528 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2529 }
2530
2531
2532 void
2533 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2534 gfc_expr *set ATTRIBUTE_UNUSED,
2535 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2536 {
2537 f->ts.type = BT_INTEGER;
2538 if (kind)
2539 f->ts.kind = mpz_get_si (kind->value.integer);
2540 else
2541 f->ts.kind = gfc_default_integer_kind;
2542 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2543 }
2544
2545
2546 void
2547 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2548 {
2549 t1->ts = t0->ts;
2550 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2551 }
2552
2553
2554 void
2555 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2556 gfc_expr *i ATTRIBUTE_UNUSED)
2557 {
2558 f->ts = x->ts;
2559 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2560 }
2561
2562
2563 void
2564 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2565 {
2566 f->ts.type = BT_INTEGER;
2567
2568 if (kind)
2569 f->ts.kind = mpz_get_si (kind->value.integer);
2570 else
2571 f->ts.kind = gfc_default_integer_kind;
2572
2573 f->rank = 1;
2574 if (array->rank != -1)
2575 {
2576 f->shape = gfc_get_shape (1);
2577 mpz_init_set_ui (f->shape[0], array->rank);
2578 }
2579
2580 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2581 }
2582
2583
2584 void
2585 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2586 {
2587 f->ts = i->ts;
2588 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2589 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2590 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2591 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2592 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2593 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2594 else
2595 gcc_unreachable ();
2596 }
2597
2598
2599 void
2600 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2601 {
2602 f->ts = a->ts;
2603 f->value.function.name
2604 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
2605 gfc_type_abi_kind (&a->ts));
2606 }
2607
2608
2609 void
2610 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2611 {
2612 f->ts.type = BT_INTEGER;
2613 f->ts.kind = gfc_c_int_kind;
2614
2615 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2616 if (handler->ts.type == BT_INTEGER)
2617 {
2618 if (handler->ts.kind != gfc_c_int_kind)
2619 gfc_convert_type (handler, &f->ts, 2);
2620 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2621 }
2622 else
2623 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2624
2625 if (number->ts.kind != gfc_c_int_kind)
2626 gfc_convert_type (number, &f->ts, 2);
2627 }
2628
2629
2630 void
2631 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2632 {
2633 f->ts = x->ts;
2634 f->value.function.name
2635 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2636 gfc_type_abi_kind (&x->ts));
2637 }
2638
2639
2640 void
2641 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2642 {
2643 f->ts = x->ts;
2644 f->value.function.name
2645 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
2646 gfc_type_abi_kind (&x->ts));
2647 }
2648
2649
2650 void
2651 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2652 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2653 {
2654 f->ts.type = BT_INTEGER;
2655 if (kind)
2656 f->ts.kind = mpz_get_si (kind->value.integer);
2657 else
2658 f->ts.kind = gfc_default_integer_kind;
2659 }
2660
2661
2662 void
2663 gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2664 gfc_expr *dim ATTRIBUTE_UNUSED)
2665 {
2666 f->ts.type = BT_INTEGER;
2667 f->ts.kind = gfc_index_integer_kind;
2668 }
2669
2670
2671 void
2672 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2673 {
2674 f->ts = x->ts;
2675 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2676 }
2677
2678
2679 void
2680 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2681 gfc_expr *ncopies)
2682 {
2683 if (source->ts.type == BT_CHARACTER && source->ref)
2684 gfc_resolve_substring_charlen (source);
2685
2686 if (source->ts.type == BT_CHARACTER)
2687 check_charlen_present (source);
2688
2689 f->ts = source->ts;
2690 f->rank = source->rank + 1;
2691 if (source->rank == 0)
2692 {
2693 if (source->ts.type == BT_CHARACTER)
2694 f->value.function.name
2695 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2696 : gfc_get_string
2697 (PREFIX ("spread_char%d_scalar"),
2698 source->ts.kind);
2699 else
2700 f->value.function.name = PREFIX ("spread_scalar");
2701 }
2702 else
2703 {
2704 if (source->ts.type == BT_CHARACTER)
2705 f->value.function.name
2706 = source->ts.kind == 1 ? PREFIX ("spread_char")
2707 : gfc_get_string
2708 (PREFIX ("spread_char%d"),
2709 source->ts.kind);
2710 else
2711 f->value.function.name = PREFIX ("spread");
2712 }
2713
2714 if (dim && gfc_is_constant_expr (dim)
2715 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2716 {
2717 int i, idim;
2718 idim = mpz_get_ui (dim->value.integer);
2719 f->shape = gfc_get_shape (f->rank);
2720 for (i = 0; i < (idim - 1); i++)
2721 mpz_init_set (f->shape[i], source->shape[i]);
2722
2723 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2724
2725 for (i = idim; i < f->rank ; i++)
2726 mpz_init_set (f->shape[i], source->shape[i-1]);
2727 }
2728
2729
2730 gfc_resolve_dim_arg (dim);
2731 gfc_resolve_index (ncopies, 1);
2732 }
2733
2734
2735 void
2736 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2737 {
2738 f->ts = x->ts;
2739 f->value.function.name
2740 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
2741 gfc_type_abi_kind (&x->ts));
2742 }
2743
2744
2745 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2746
2747 void
2748 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2749 gfc_expr *a ATTRIBUTE_UNUSED)
2750 {
2751 f->ts.type = BT_INTEGER;
2752 f->ts.kind = gfc_default_integer_kind;
2753 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2754 }
2755
2756
2757 void
2758 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2759 gfc_expr *a ATTRIBUTE_UNUSED)
2760 {
2761 f->ts.type = BT_INTEGER;
2762 f->ts.kind = gfc_default_integer_kind;
2763 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2764 }
2765
2766
2767 void
2768 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2769 {
2770 f->ts.type = BT_INTEGER;
2771 f->ts.kind = gfc_default_integer_kind;
2772 if (n->ts.kind != f->ts.kind)
2773 gfc_convert_type (n, &f->ts, 2);
2774
2775 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2776 }
2777
2778
2779 void
2780 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2781 {
2782 gfc_typespec ts;
2783 gfc_clear_ts (&ts);
2784
2785 f->ts.type = BT_INTEGER;
2786 f->ts.kind = gfc_c_int_kind;
2787 if (u->ts.kind != gfc_c_int_kind)
2788 {
2789 ts.type = BT_INTEGER;
2790 ts.kind = gfc_c_int_kind;
2791 ts.u.derived = NULL;
2792 ts.u.cl = NULL;
2793 gfc_convert_type (u, &ts, 2);
2794 }
2795
2796 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2797 }
2798
2799
2800 void
2801 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2802 {
2803 f->ts.type = BT_INTEGER;
2804 f->ts.kind = gfc_c_int_kind;
2805 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2806 }
2807
2808
2809 void
2810 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2811 {
2812 gfc_typespec ts;
2813 gfc_clear_ts (&ts);
2814
2815 f->ts.type = BT_INTEGER;
2816 f->ts.kind = gfc_c_int_kind;
2817 if (u->ts.kind != gfc_c_int_kind)
2818 {
2819 ts.type = BT_INTEGER;
2820 ts.kind = gfc_c_int_kind;
2821 ts.u.derived = NULL;
2822 ts.u.cl = NULL;
2823 gfc_convert_type (u, &ts, 2);
2824 }
2825
2826 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2827 }
2828
2829
2830 void
2831 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2832 {
2833 f->ts.type = BT_INTEGER;
2834 f->ts.kind = gfc_c_int_kind;
2835 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2836 }
2837
2838
2839 void
2840 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2841 {
2842 gfc_typespec ts;
2843 gfc_clear_ts (&ts);
2844
2845 f->ts.type = BT_INTEGER;
2846 f->ts.kind = gfc_intio_kind;
2847 if (u->ts.kind != gfc_c_int_kind)
2848 {
2849 ts.type = BT_INTEGER;
2850 ts.kind = gfc_c_int_kind;
2851 ts.u.derived = NULL;
2852 ts.u.cl = NULL;
2853 gfc_convert_type (u, &ts, 2);
2854 }
2855
2856 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2857 }
2858
2859
2860 void
2861 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2862 gfc_expr *kind)
2863 {
2864 f->ts.type = BT_INTEGER;
2865 if (kind)
2866 f->ts.kind = mpz_get_si (kind->value.integer);
2867 else
2868 f->ts.kind = gfc_default_integer_kind;
2869 }
2870
2871
2872 void
2873 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2874 {
2875 resolve_transformational ("sum", f, array, dim, mask);
2876 }
2877
2878
2879 void
2880 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2881 gfc_expr *p2 ATTRIBUTE_UNUSED)
2882 {
2883 f->ts.type = BT_INTEGER;
2884 f->ts.kind = gfc_default_integer_kind;
2885 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2886 }
2887
2888
2889 /* Resolve the g77 compatibility function SYSTEM. */
2890
2891 void
2892 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2893 {
2894 f->ts.type = BT_INTEGER;
2895 f->ts.kind = 4;
2896 f->value.function.name = gfc_get_string (PREFIX ("system"));
2897 }
2898
2899
2900 void
2901 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2902 {
2903 f->ts = x->ts;
2904 f->value.function.name
2905 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
2906 gfc_type_abi_kind (&x->ts));
2907 }
2908
2909
2910 void
2911 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2912 {
2913 f->ts = x->ts;
2914 f->value.function.name
2915 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
2916 gfc_type_abi_kind (&x->ts));
2917 }
2918
2919
2920 /* Resolve failed_images (team, kind). */
2921
2922 void
2923 gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2924 gfc_expr *kind)
2925 {
2926 static char failed_images[] = "_gfortran_caf_failed_images";
2927 f->rank = 1;
2928 f->ts.type = BT_INTEGER;
2929 if (kind == NULL)
2930 f->ts.kind = gfc_default_integer_kind;
2931 else
2932 gfc_extract_int (kind, &f->ts.kind);
2933 f->value.function.name = failed_images;
2934 }
2935
2936
2937 /* Resolve image_status (image, team). */
2938
2939 void
2940 gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2941 gfc_expr *team ATTRIBUTE_UNUSED)
2942 {
2943 static char image_status[] = "_gfortran_caf_image_status";
2944 f->ts.type = BT_INTEGER;
2945 f->ts.kind = gfc_default_integer_kind;
2946 f->value.function.name = image_status;
2947 }
2948
2949
2950 /* Resolve get_team (). */
2951
2952 void
2953 gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2954 {
2955 static char get_team[] = "_gfortran_caf_get_team";
2956 f->rank = 0;
2957 f->ts.type = BT_INTEGER;
2958 f->ts.kind = gfc_default_integer_kind;
2959 f->value.function.name = get_team;
2960 }
2961
2962
2963 /* Resolve image_index (...). */
2964
2965 void
2966 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2967 gfc_expr *sub ATTRIBUTE_UNUSED)
2968 {
2969 static char image_index[] = "__image_index";
2970 f->ts.type = BT_INTEGER;
2971 f->ts.kind = gfc_default_integer_kind;
2972 f->value.function.name = image_index;
2973 }
2974
2975
2976 /* Resolve stopped_images (team, kind). */
2977
2978 void
2979 gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2980 gfc_expr *kind)
2981 {
2982 static char stopped_images[] = "_gfortran_caf_stopped_images";
2983 f->rank = 1;
2984 f->ts.type = BT_INTEGER;
2985 if (kind == NULL)
2986 f->ts.kind = gfc_default_integer_kind;
2987 else
2988 gfc_extract_int (kind, &f->ts.kind);
2989 f->value.function.name = stopped_images;
2990 }
2991
2992
2993 /* Resolve team_number (team). */
2994
2995 void
2996 gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
2997 {
2998 static char team_number[] = "_gfortran_caf_team_number";
2999 f->rank = 0;
3000 f->ts.type = BT_INTEGER;
3001 f->ts.kind = gfc_default_integer_kind;
3002 f->value.function.name = team_number;
3003 }
3004
3005
3006 void
3007 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
3008 gfc_expr *distance ATTRIBUTE_UNUSED)
3009 {
3010 static char this_image[] = "__this_image";
3011 if (array && gfc_is_coarray (array))
3012 resolve_bound (f, array, dim, NULL, "__this_image", true);
3013 else
3014 {
3015 f->ts.type = BT_INTEGER;
3016 f->ts.kind = gfc_default_integer_kind;
3017 f->value.function.name = this_image;
3018 }
3019 }
3020
3021
3022 void
3023 gfc_resolve_time (gfc_expr *f)
3024 {
3025 f->ts.type = BT_INTEGER;
3026 f->ts.kind = 4;
3027 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
3028 }
3029
3030
3031 void
3032 gfc_resolve_time8 (gfc_expr *f)
3033 {
3034 f->ts.type = BT_INTEGER;
3035 f->ts.kind = 8;
3036 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
3037 }
3038
3039
3040 void
3041 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
3042 gfc_expr *mold, gfc_expr *size)
3043 {
3044 /* TODO: Make this do something meaningful. */
3045 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3046
3047 if (mold->ts.type == BT_CHARACTER
3048 && !mold->ts.u.cl->length
3049 && gfc_is_constant_expr (mold))
3050 {
3051 int len;
3052 if (mold->expr_type == EXPR_CONSTANT)
3053 {
3054 len = mold->value.character.length;
3055 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3056 NULL, len);
3057 }
3058 else
3059 {
3060 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3061 len = c->expr->value.character.length;
3062 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3063 NULL, len);
3064 }
3065 }
3066
3067 if (UNLIMITED_POLY (mold))
3068 gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3069 &mold->where);
3070
3071 f->ts = mold->ts;
3072
3073 if (size == NULL && mold->rank == 0)
3074 {
3075 f->rank = 0;
3076 f->value.function.name = transfer0;
3077 }
3078 else
3079 {
3080 f->rank = 1;
3081 f->value.function.name = transfer1;
3082 if (size && gfc_is_constant_expr (size))
3083 {
3084 f->shape = gfc_get_shape (1);
3085 mpz_init_set (f->shape[0], size->value.integer);
3086 }
3087 }
3088 }
3089
3090
3091 void
3092 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3093 {
3094
3095 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3096 gfc_resolve_substring_charlen (matrix);
3097
3098 f->ts = matrix->ts;
3099 f->rank = 2;
3100 if (matrix->shape)
3101 {
3102 f->shape = gfc_get_shape (2);
3103 mpz_init_set (f->shape[0], matrix->shape[1]);
3104 mpz_init_set (f->shape[1], matrix->shape[0]);
3105 }
3106
3107 switch (matrix->ts.kind)
3108 {
3109 case 4:
3110 case 8:
3111 case 10:
3112 case 16:
3113 switch (matrix->ts.type)
3114 {
3115 case BT_REAL:
3116 case BT_COMPLEX:
3117 f->value.function.name
3118 = gfc_get_string (PREFIX ("transpose_%c%d"),
3119 gfc_type_letter (matrix->ts.type),
3120 gfc_type_abi_kind (&matrix->ts));
3121 break;
3122
3123 case BT_INTEGER:
3124 case BT_LOGICAL:
3125 /* Use the integer routines for real and logical cases. This
3126 assumes they all have the same alignment requirements. */
3127 f->value.function.name
3128 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3129 break;
3130
3131 default:
3132 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3133 f->value.function.name = PREFIX ("transpose_char4");
3134 else
3135 f->value.function.name = PREFIX ("transpose");
3136 break;
3137 }
3138 break;
3139
3140 default:
3141 f->value.function.name = (matrix->ts.type == BT_CHARACTER
3142 ? PREFIX ("transpose_char")
3143 : PREFIX ("transpose"));
3144 break;
3145 }
3146 }
3147
3148
3149 void
3150 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3151 {
3152 f->ts.type = BT_CHARACTER;
3153 f->ts.kind = string->ts.kind;
3154 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3155 }
3156
3157
3158 /* Resolve the degree trigonometric functions. This amounts to setting
3159 the function return type-spec from its argument and building a
3160 library function names of the form _gfortran_sind_r4. */
3161
3162 void
3163 gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3164 {
3165 f->ts = x->ts;
3166 f->value.function.name
3167 = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3168 gfc_type_letter (x->ts.type),
3169 gfc_type_abi_kind (&x->ts));
3170 }
3171
3172
3173 void
3174 gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3175 {
3176 f->ts = y->ts;
3177 f->value.function.name
3178 = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3179 x->ts.kind);
3180 }
3181
3182
3183 void
3184 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3185 {
3186 resolve_bound (f, array, dim, kind, "__ubound", false);
3187 }
3188
3189
3190 void
3191 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3192 {
3193 resolve_bound (f, array, dim, kind, "__ucobound", true);
3194 }
3195
3196
3197 /* Resolve the g77 compatibility function UMASK. */
3198
3199 void
3200 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3201 {
3202 f->ts.type = BT_INTEGER;
3203 f->ts.kind = n->ts.kind;
3204 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3205 }
3206
3207
3208 /* Resolve the g77 compatibility function UNLINK. */
3209
3210 void
3211 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3212 {
3213 f->ts.type = BT_INTEGER;
3214 f->ts.kind = 4;
3215 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3216 }
3217
3218
3219 void
3220 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3221 {
3222 gfc_typespec ts;
3223 gfc_clear_ts (&ts);
3224
3225 f->ts.type = BT_CHARACTER;
3226 f->ts.kind = gfc_default_character_kind;
3227
3228 if (unit->ts.kind != gfc_c_int_kind)
3229 {
3230 ts.type = BT_INTEGER;
3231 ts.kind = gfc_c_int_kind;
3232 ts.u.derived = NULL;
3233 ts.u.cl = NULL;
3234 gfc_convert_type (unit, &ts, 2);
3235 }
3236
3237 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3238 }
3239
3240
3241 void
3242 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3243 gfc_expr *field ATTRIBUTE_UNUSED)
3244 {
3245 if (vector->ts.type == BT_CHARACTER && vector->ref)
3246 gfc_resolve_substring_charlen (vector);
3247
3248 f->ts = vector->ts;
3249 f->rank = mask->rank;
3250 resolve_mask_arg (mask);
3251
3252 if (vector->ts.type == BT_CHARACTER)
3253 {
3254 if (vector->ts.kind == 1)
3255 f->value.function.name
3256 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3257 else
3258 f->value.function.name
3259 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3260 field->rank > 0 ? 1 : 0, vector->ts.kind);
3261 }
3262 else
3263 f->value.function.name
3264 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3265 }
3266
3267
3268 void
3269 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3270 gfc_expr *set ATTRIBUTE_UNUSED,
3271 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3272 {
3273 f->ts.type = BT_INTEGER;
3274 if (kind)
3275 f->ts.kind = mpz_get_si (kind->value.integer);
3276 else
3277 f->ts.kind = gfc_default_integer_kind;
3278 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3279 }
3280
3281
3282 void
3283 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3284 {
3285 f->ts.type = i->ts.type;
3286 f->ts.kind = gfc_kind_max (i, j);
3287
3288 if (i->ts.kind != j->ts.kind)
3289 {
3290 if (i->ts.kind == gfc_kind_max (i, j))
3291 gfc_convert_type (j, &i->ts, 2);
3292 else
3293 gfc_convert_type (i, &j->ts, 2);
3294 }
3295
3296 f->value.function.name
3297 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3298 gfc_type_abi_kind (&f->ts));
3299 }
3300
3301
3302 /* Intrinsic subroutine resolution. */
3303
3304 void
3305 gfc_resolve_alarm_sub (gfc_code *c)
3306 {
3307 const char *name;
3308 gfc_expr *seconds, *handler;
3309 gfc_typespec ts;
3310 gfc_clear_ts (&ts);
3311
3312 seconds = c->ext.actual->expr;
3313 handler = c->ext.actual->next->expr;
3314 ts.type = BT_INTEGER;
3315 ts.kind = gfc_c_int_kind;
3316
3317 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3318 In all cases, the status argument is of default integer kind
3319 (enforced in check.cc) so that the function suffix is fixed. */
3320 if (handler->ts.type == BT_INTEGER)
3321 {
3322 if (handler->ts.kind != gfc_c_int_kind)
3323 gfc_convert_type (handler, &ts, 2);
3324 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3325 gfc_default_integer_kind);
3326 }
3327 else
3328 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3329 gfc_default_integer_kind);
3330
3331 if (seconds->ts.kind != gfc_c_int_kind)
3332 gfc_convert_type (seconds, &ts, 2);
3333
3334 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3335 }
3336
3337 void
3338 gfc_resolve_cpu_time (gfc_code *c)
3339 {
3340 const char *name;
3341 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3342 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3343 }
3344
3345
3346 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3347
3348 static gfc_formal_arglist*
3349 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3350 {
3351 gfc_formal_arglist* head;
3352 gfc_formal_arglist* tail;
3353 int i;
3354
3355 if (!actual)
3356 return NULL;
3357
3358 head = tail = gfc_get_formal_arglist ();
3359 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3360 {
3361 gfc_symbol* sym;
3362
3363 sym = gfc_new_symbol ("dummyarg", NULL);
3364 sym->ts = actual->expr->ts;
3365
3366 sym->attr.intent = ints[i];
3367 tail->sym = sym;
3368
3369 if (actual->next)
3370 tail->next = gfc_get_formal_arglist ();
3371 }
3372
3373 return head;
3374 }
3375
3376
3377 void
3378 gfc_resolve_atomic_def (gfc_code *c)
3379 {
3380 const char *name = "atomic_define";
3381 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3382 }
3383
3384
3385 void
3386 gfc_resolve_atomic_ref (gfc_code *c)
3387 {
3388 const char *name = "atomic_ref";
3389 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3390 }
3391
3392 void
3393 gfc_resolve_event_query (gfc_code *c)
3394 {
3395 const char *name = "event_query";
3396 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3397 }
3398
3399 void
3400 gfc_resolve_mvbits (gfc_code *c)
3401 {
3402 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3403 INTENT_INOUT, INTENT_IN};
3404 const char *name;
3405
3406 /* TO and FROM are guaranteed to have the same kind parameter. */
3407 name = gfc_get_string (PREFIX ("mvbits_i%d"),
3408 c->ext.actual->expr->ts.kind);
3409 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3410 /* Mark as elemental subroutine as this does not happen automatically. */
3411 c->resolved_sym->attr.elemental = 1;
3412
3413 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3414 of creating temporaries. */
3415 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3416 }
3417
3418
3419 /* Set up the call to RANDOM_INIT. */
3420
3421 void
3422 gfc_resolve_random_init (gfc_code *c)
3423 {
3424 const char *name;
3425 name = gfc_get_string (PREFIX ("random_init"));
3426 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3427 }
3428
3429
3430 void
3431 gfc_resolve_random_number (gfc_code *c)
3432 {
3433 const char *name;
3434 int kind;
3435
3436 kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3437 if (c->ext.actual->expr->rank == 0)
3438 name = gfc_get_string (PREFIX ("random_r%d"), kind);
3439 else
3440 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3441
3442 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3443 }
3444
3445
3446 void
3447 gfc_resolve_random_seed (gfc_code *c)
3448 {
3449 const char *name;
3450
3451 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3452 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3453 }
3454
3455
3456 void
3457 gfc_resolve_rename_sub (gfc_code *c)
3458 {
3459 const char *name;
3460 int kind;
3461
3462 /* Find the type of status. If not present use default integer kind. */
3463 if (c->ext.actual->next->next->expr != NULL)
3464 kind = c->ext.actual->next->next->expr->ts.kind;
3465 else
3466 kind = gfc_default_integer_kind;
3467
3468 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3469 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3470 }
3471
3472
3473 void
3474 gfc_resolve_link_sub (gfc_code *c)
3475 {
3476 const char *name;
3477 int kind;
3478
3479 if (c->ext.actual->next->next->expr != NULL)
3480 kind = c->ext.actual->next->next->expr->ts.kind;
3481 else
3482 kind = gfc_default_integer_kind;
3483
3484 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3485 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3486 }
3487
3488
3489 void
3490 gfc_resolve_symlnk_sub (gfc_code *c)
3491 {
3492 const char *name;
3493 int kind;
3494
3495 if (c->ext.actual->next->next->expr != NULL)
3496 kind = c->ext.actual->next->next->expr->ts.kind;
3497 else
3498 kind = gfc_default_integer_kind;
3499
3500 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3501 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3502 }
3503
3504
3505 /* G77 compatibility subroutines dtime() and etime(). */
3506
3507 void
3508 gfc_resolve_dtime_sub (gfc_code *c)
3509 {
3510 const char *name;
3511 name = gfc_get_string (PREFIX ("dtime_sub"));
3512 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3513 }
3514
3515 void
3516 gfc_resolve_etime_sub (gfc_code *c)
3517 {
3518 const char *name;
3519 name = gfc_get_string (PREFIX ("etime_sub"));
3520 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3521 }
3522
3523
3524 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3525
3526 void
3527 gfc_resolve_itime (gfc_code *c)
3528 {
3529 c->resolved_sym
3530 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3531 gfc_default_integer_kind));
3532 }
3533
3534 void
3535 gfc_resolve_idate (gfc_code *c)
3536 {
3537 c->resolved_sym
3538 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3539 gfc_default_integer_kind));
3540 }
3541
3542 void
3543 gfc_resolve_ltime (gfc_code *c)
3544 {
3545 c->resolved_sym
3546 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3547 gfc_default_integer_kind));
3548 }
3549
3550 void
3551 gfc_resolve_gmtime (gfc_code *c)
3552 {
3553 c->resolved_sym
3554 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3555 gfc_default_integer_kind));
3556 }
3557
3558
3559 /* G77 compatibility subroutine second(). */
3560
3561 void
3562 gfc_resolve_second_sub (gfc_code *c)
3563 {
3564 const char *name;
3565 name = gfc_get_string (PREFIX ("second_sub"));
3566 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3567 }
3568
3569
3570 void
3571 gfc_resolve_sleep_sub (gfc_code *c)
3572 {
3573 const char *name;
3574 int kind;
3575
3576 if (c->ext.actual->expr != NULL)
3577 kind = c->ext.actual->expr->ts.kind;
3578 else
3579 kind = gfc_default_integer_kind;
3580
3581 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3582 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3583 }
3584
3585
3586 /* G77 compatibility function srand(). */
3587
3588 void
3589 gfc_resolve_srand (gfc_code *c)
3590 {
3591 const char *name;
3592 name = gfc_get_string (PREFIX ("srand"));
3593 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3594 }
3595
3596
3597 /* Resolve the getarg intrinsic subroutine. */
3598
3599 void
3600 gfc_resolve_getarg (gfc_code *c)
3601 {
3602 const char *name;
3603
3604 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3605 {
3606 gfc_typespec ts;
3607 gfc_clear_ts (&ts);
3608
3609 ts.type = BT_INTEGER;
3610 ts.kind = gfc_default_integer_kind;
3611
3612 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3613 }
3614
3615 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3616 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3617 }
3618
3619
3620 /* Resolve the getcwd intrinsic subroutine. */
3621
3622 void
3623 gfc_resolve_getcwd_sub (gfc_code *c)
3624 {
3625 const char *name;
3626 int kind;
3627
3628 if (c->ext.actual->next->expr != NULL)
3629 kind = c->ext.actual->next->expr->ts.kind;
3630 else
3631 kind = gfc_default_integer_kind;
3632
3633 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3634 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3635 }
3636
3637
3638 /* Resolve the get_command intrinsic subroutine. */
3639
3640 void
3641 gfc_resolve_get_command (gfc_code *c)
3642 {
3643 const char *name;
3644 int kind;
3645 kind = gfc_default_integer_kind;
3646 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3647 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3648 }
3649
3650
3651 /* Resolve the get_command_argument intrinsic subroutine. */
3652
3653 void
3654 gfc_resolve_get_command_argument (gfc_code *c)
3655 {
3656 const char *name;
3657 int kind;
3658 kind = gfc_default_integer_kind;
3659 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3660 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3661 }
3662
3663
3664 /* Resolve the get_environment_variable intrinsic subroutine. */
3665
3666 void
3667 gfc_resolve_get_environment_variable (gfc_code *code)
3668 {
3669 const char *name;
3670 int kind;
3671 kind = gfc_default_integer_kind;
3672 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3673 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3674 }
3675
3676
3677 void
3678 gfc_resolve_signal_sub (gfc_code *c)
3679 {
3680 const char *name;
3681 gfc_expr *number, *handler, *status;
3682 gfc_typespec ts;
3683 gfc_clear_ts (&ts);
3684
3685 number = c->ext.actual->expr;
3686 handler = c->ext.actual->next->expr;
3687 status = c->ext.actual->next->next->expr;
3688 ts.type = BT_INTEGER;
3689 ts.kind = gfc_c_int_kind;
3690
3691 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3692 if (handler->ts.type == BT_INTEGER)
3693 {
3694 if (handler->ts.kind != gfc_c_int_kind)
3695 gfc_convert_type (handler, &ts, 2);
3696 name = gfc_get_string (PREFIX ("signal_sub_int"));
3697 }
3698 else
3699 name = gfc_get_string (PREFIX ("signal_sub"));
3700
3701 if (number->ts.kind != gfc_c_int_kind)
3702 gfc_convert_type (number, &ts, 2);
3703 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3704 gfc_convert_type (status, &ts, 2);
3705
3706 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3707 }
3708
3709
3710 /* Resolve the SYSTEM intrinsic subroutine. */
3711
3712 void
3713 gfc_resolve_system_sub (gfc_code *c)
3714 {
3715 const char *name;
3716 name = gfc_get_string (PREFIX ("system_sub"));
3717 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3718 }
3719
3720
3721 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3722
3723 void
3724 gfc_resolve_system_clock (gfc_code *c)
3725 {
3726 const char *name;
3727 int kind;
3728 gfc_expr *count = c->ext.actual->expr;
3729 gfc_expr *count_max = c->ext.actual->next->next->expr;
3730
3731 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3732 and COUNT_MAX can hold 64-bit values, or are absent. */
3733 if ((!count || count->ts.kind >= 8)
3734 && (!count_max || count_max->ts.kind >= 8))
3735 kind = 8;
3736 else
3737 kind = gfc_default_integer_kind;
3738
3739 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3740 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3741 }
3742
3743
3744 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3745 void
3746 gfc_resolve_execute_command_line (gfc_code *c)
3747 {
3748 const char *name;
3749 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3750 gfc_default_integer_kind);
3751 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3752 }
3753
3754
3755 /* Resolve the EXIT intrinsic subroutine. */
3756
3757 void
3758 gfc_resolve_exit (gfc_code *c)
3759 {
3760 const char *name;
3761 gfc_typespec ts;
3762 gfc_expr *n;
3763 gfc_clear_ts (&ts);
3764
3765 /* The STATUS argument has to be of default kind. If it is not,
3766 we convert it. */
3767 ts.type = BT_INTEGER;
3768 ts.kind = gfc_default_integer_kind;
3769 n = c->ext.actual->expr;
3770 if (n != NULL && n->ts.kind != ts.kind)
3771 gfc_convert_type (n, &ts, 2);
3772
3773 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3774 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3775 }
3776
3777
3778 /* Resolve the FLUSH intrinsic subroutine. */
3779
3780 void
3781 gfc_resolve_flush (gfc_code *c)
3782 {
3783 const char *name;
3784 gfc_typespec ts;
3785 gfc_expr *n;
3786 gfc_clear_ts (&ts);
3787
3788 ts.type = BT_INTEGER;
3789 ts.kind = gfc_default_integer_kind;
3790 n = c->ext.actual->expr;
3791 if (n != NULL && n->ts.kind != ts.kind)
3792 gfc_convert_type (n, &ts, 2);
3793
3794 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3795 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3796 }
3797
3798
3799 void
3800 gfc_resolve_ctime_sub (gfc_code *c)
3801 {
3802 gfc_typespec ts;
3803 gfc_clear_ts (&ts);
3804
3805 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3806 if (c->ext.actual->expr->ts.kind != 8)
3807 {
3808 ts.type = BT_INTEGER;
3809 ts.kind = 8;
3810 ts.u.derived = NULL;
3811 ts.u.cl = NULL;
3812 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3813 }
3814
3815 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3816 }
3817
3818
3819 void
3820 gfc_resolve_fdate_sub (gfc_code *c)
3821 {
3822 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3823 }
3824
3825
3826 void
3827 gfc_resolve_gerror (gfc_code *c)
3828 {
3829 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3830 }
3831
3832
3833 void
3834 gfc_resolve_getlog (gfc_code *c)
3835 {
3836 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3837 }
3838
3839
3840 void
3841 gfc_resolve_hostnm_sub (gfc_code *c)
3842 {
3843 const char *name;
3844 int kind;
3845
3846 if (c->ext.actual->next->expr != NULL)
3847 kind = c->ext.actual->next->expr->ts.kind;
3848 else
3849 kind = gfc_default_integer_kind;
3850
3851 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3852 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3853 }
3854
3855
3856 void
3857 gfc_resolve_perror (gfc_code *c)
3858 {
3859 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3860 }
3861
3862 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3863
3864 void
3865 gfc_resolve_stat_sub (gfc_code *c)
3866 {
3867 const char *name;
3868 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3869 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3870 }
3871
3872
3873 void
3874 gfc_resolve_lstat_sub (gfc_code *c)
3875 {
3876 const char *name;
3877 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3878 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3879 }
3880
3881
3882 void
3883 gfc_resolve_fstat_sub (gfc_code *c)
3884 {
3885 const char *name;
3886 gfc_expr *u;
3887 gfc_typespec *ts;
3888
3889 u = c->ext.actual->expr;
3890 ts = &c->ext.actual->next->expr->ts;
3891 if (u->ts.kind != ts->kind)
3892 gfc_convert_type (u, ts, 2);
3893 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3894 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3895 }
3896
3897
3898 void
3899 gfc_resolve_fgetc_sub (gfc_code *c)
3900 {
3901 const char *name;
3902 gfc_typespec ts;
3903 gfc_expr *u, *st;
3904 gfc_clear_ts (&ts);
3905
3906 u = c->ext.actual->expr;
3907 st = c->ext.actual->next->next->expr;
3908
3909 if (u->ts.kind != gfc_c_int_kind)
3910 {
3911 ts.type = BT_INTEGER;
3912 ts.kind = gfc_c_int_kind;
3913 ts.u.derived = NULL;
3914 ts.u.cl = NULL;
3915 gfc_convert_type (u, &ts, 2);
3916 }
3917
3918 if (st != NULL)
3919 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3920 else
3921 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3922
3923 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3924 }
3925
3926
3927 void
3928 gfc_resolve_fget_sub (gfc_code *c)
3929 {
3930 const char *name;
3931 gfc_expr *st;
3932
3933 st = c->ext.actual->next->expr;
3934 if (st != NULL)
3935 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3936 else
3937 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3938
3939 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3940 }
3941
3942
3943 void
3944 gfc_resolve_fputc_sub (gfc_code *c)
3945 {
3946 const char *name;
3947 gfc_typespec ts;
3948 gfc_expr *u, *st;
3949 gfc_clear_ts (&ts);
3950
3951 u = c->ext.actual->expr;
3952 st = c->ext.actual->next->next->expr;
3953
3954 if (u->ts.kind != gfc_c_int_kind)
3955 {
3956 ts.type = BT_INTEGER;
3957 ts.kind = gfc_c_int_kind;
3958 ts.u.derived = NULL;
3959 ts.u.cl = NULL;
3960 gfc_convert_type (u, &ts, 2);
3961 }
3962
3963 if (st != NULL)
3964 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3965 else
3966 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3967
3968 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3969 }
3970
3971
3972 void
3973 gfc_resolve_fput_sub (gfc_code *c)
3974 {
3975 const char *name;
3976 gfc_expr *st;
3977
3978 st = c->ext.actual->next->expr;
3979 if (st != NULL)
3980 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3981 else
3982 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3983
3984 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3985 }
3986
3987
3988 void
3989 gfc_resolve_fseek_sub (gfc_code *c)
3990 {
3991 gfc_expr *unit;
3992 gfc_expr *offset;
3993 gfc_expr *whence;
3994 gfc_typespec ts;
3995 gfc_clear_ts (&ts);
3996
3997 unit = c->ext.actual->expr;
3998 offset = c->ext.actual->next->expr;
3999 whence = c->ext.actual->next->next->expr;
4000
4001 if (unit->ts.kind != gfc_c_int_kind)
4002 {
4003 ts.type = BT_INTEGER;
4004 ts.kind = gfc_c_int_kind;
4005 ts.u.derived = NULL;
4006 ts.u.cl = NULL;
4007 gfc_convert_type (unit, &ts, 2);
4008 }
4009
4010 if (offset->ts.kind != gfc_intio_kind)
4011 {
4012 ts.type = BT_INTEGER;
4013 ts.kind = gfc_intio_kind;
4014 ts.u.derived = NULL;
4015 ts.u.cl = NULL;
4016 gfc_convert_type (offset, &ts, 2);
4017 }
4018
4019 if (whence->ts.kind != gfc_c_int_kind)
4020 {
4021 ts.type = BT_INTEGER;
4022 ts.kind = gfc_c_int_kind;
4023 ts.u.derived = NULL;
4024 ts.u.cl = NULL;
4025 gfc_convert_type (whence, &ts, 2);
4026 }
4027
4028 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4029 }
4030
4031 void
4032 gfc_resolve_ftell_sub (gfc_code *c)
4033 {
4034 const char *name;
4035 gfc_expr *unit;
4036 gfc_expr *offset;
4037 gfc_typespec ts;
4038 gfc_clear_ts (&ts);
4039
4040 unit = c->ext.actual->expr;
4041 offset = c->ext.actual->next->expr;
4042
4043 if (unit->ts.kind != gfc_c_int_kind)
4044 {
4045 ts.type = BT_INTEGER;
4046 ts.kind = gfc_c_int_kind;
4047 ts.u.derived = NULL;
4048 ts.u.cl = NULL;
4049 gfc_convert_type (unit, &ts, 2);
4050 }
4051
4052 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4053 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4054 }
4055
4056
4057 void
4058 gfc_resolve_ttynam_sub (gfc_code *c)
4059 {
4060 gfc_typespec ts;
4061 gfc_clear_ts (&ts);
4062
4063 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4064 {
4065 ts.type = BT_INTEGER;
4066 ts.kind = gfc_c_int_kind;
4067 ts.u.derived = NULL;
4068 ts.u.cl = NULL;
4069 gfc_convert_type (c->ext.actual->expr, &ts, 2);
4070 }
4071
4072 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4073 }
4074
4075
4076 /* Resolve the UMASK intrinsic subroutine. */
4077
4078 void
4079 gfc_resolve_umask_sub (gfc_code *c)
4080 {
4081 const char *name;
4082 int kind;
4083
4084 if (c->ext.actual->next->expr != NULL)
4085 kind = c->ext.actual->next->expr->ts.kind;
4086 else
4087 kind = gfc_default_integer_kind;
4088
4089 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4090 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4091 }
4092
4093 /* Resolve the UNLINK intrinsic subroutine. */
4094
4095 void
4096 gfc_resolve_unlink_sub (gfc_code *c)
4097 {
4098 const char *name;
4099 int kind;
4100
4101 if (c->ext.actual->next->expr != NULL)
4102 kind = c->ext.actual->next->expr->ts.kind;
4103 else
4104 kind = gfc_default_integer_kind;
4105
4106 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4107 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4108 }
Mirror of https://gcc.gnu.org/git/gcc.git