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