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