?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
libcpp, c, middle-end: Optimize initializers using #embed in C
[official-gcc.git] / gcc / fortran / iresolve.cc
blob9fb22128492891f9d2e848eb124cd493e5f2acb2
1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2024 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21
22 /* Assign name and types to intrinsic procedures. For functions, the
23 first argument to a resolution function is an expression pointer to
24 the original function node and the rest are pointers to the
25 arguments of the function call. For subroutines, a pointer to the
26 code node is passed. The result type and library subroutine name
27 are generally set according to the function arguments. */
28
29 #include "config.h"
30 #include "system.h"
31 #include "coretypes.h"
32 #include "tree.h"
33 #include "gfortran.h"
34 #include "stringpool.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
37 #include "arith.h"
38 #include "trans.h"
39
40 /* Given printf-like arguments, return a stable version of the result string.
41
42 We already have a working, optimized string hashing table in the form of
43 the identifier table. Reusing this table is likely not to be wasted,
44 since if the function name makes it to the gimple output of the frontend,
45 we'll have to create the identifier anyway. */
46
47 const char *
48 gfc_get_string (const char *format, ...)
49 {
50 /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 const char *str;
53 va_list ap;
54 tree ident;
55
56 /* Handle common case without vsnprintf and temporary buffer. */
57 if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 {
59 va_start (ap, format);
60 str = va_arg (ap, const char *);
61 va_end (ap);
62 }
63 else
64 {
65 int ret;
66 va_start (ap, format);
67 ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 va_end (ap);
69 if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 gfc_internal_error ("identifier overflow: %d", ret);
71 temp_name[sizeof (temp_name) - 1] = 0;
72 str = temp_name;
73 }
74
75 ident = get_identifier (str);
76 return IDENTIFIER_POINTER (ident);
77 }
78
79 /* MERGE and SPREAD need to have source charlen's present for passing
80 to the result expression. */
81 static void
82 check_charlen_present (gfc_expr *source)
83 {
84 if (source->ts.u.cl == NULL)
85 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
86
87 if (source->expr_type == EXPR_CONSTANT)
88 {
89 source->ts.u.cl->length
90 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
91 source->value.character.length);
92 source->rank = 0;
93 }
94 else if (source->expr_type == EXPR_ARRAY)
95 {
96 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
97 if (c)
98 source->ts.u.cl->length
99 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
100 c->expr->value.character.length);
101 if (source->ts.u.cl->length == NULL)
102 gfc_internal_error ("check_charlen_present(): length not set");
103 }
104 }
105
106 /* Helper function for resolving the "mask" argument. */
107
108 static void
109 resolve_mask_arg (gfc_expr *mask)
110 {
111
112 gfc_typespec ts;
113 gfc_clear_ts (&ts);
114
115 if (mask->rank == 0)
116 {
117 /* For the scalar case, coerce the mask to kind=4 unconditionally
118 (because this is the only kind we have a library function
119 for). */
120
121 if (mask->ts.kind != 4)
122 {
123 ts.type = BT_LOGICAL;
124 ts.kind = 4;
125 gfc_convert_type (mask, &ts, 2);
126 }
127 }
128 else
129 {
130 /* In the library, we access the mask with a GFC_LOGICAL_1
131 argument. No need to waste memory if we are about to create
132 a temporary array. */
133 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
134 {
135 ts.type = BT_LOGICAL;
136 ts.kind = 1;
137 gfc_convert_type_warn (mask, &ts, 2, 0);
138 }
139 }
140 }
141
142
143 static void
144 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145 const char *name, bool coarray)
146 {
147 f->ts.type = BT_INTEGER;
148 if (kind)
149 f->ts.kind = mpz_get_si (kind->value.integer);
150 else
151 f->ts.kind = gfc_default_integer_kind;
152
153 if (dim == NULL)
154 {
155 if (array->rank != -1)
156 {
157 /* Assume f->rank gives the size of the shape, because there is no
158 other way to determine the size. */
159 if (!f->shape || f->rank != 1)
160 {
161 if (f->shape)
162 gfc_free_shape (&f->shape, f->rank);
163 f->shape = gfc_get_shape (1);
164 }
165 mpz_init_set_ui (f->shape[0], coarray ? array->corank : array->rank);
166 }
167 /* Applying bound to a coarray always results in a regular array. */
168 f->rank = 1;
169 f->corank = 0;
170 }
171
172 f->value.function.name = gfc_get_string ("%s", name);
173 }
174
175
176 static void
177 resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
178 gfc_expr *dim, gfc_expr *mask,
179 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
2015 void
2016 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
2017 gfc_expr *fsource ATTRIBUTE_UNUSED,
2018 gfc_expr *mask ATTRIBUTE_UNUSED)
2019 {
2020 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
2021 gfc_resolve_substring_charlen (tsource);
2022
2023 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
2024 gfc_resolve_substring_charlen (fsource);
2025
2026 if (tsource->ts.type == BT_CHARACTER)
2027 check_charlen_present (tsource);
2028
2029 f->ts = tsource->ts;
2030 f->value.function.name
2031 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
2032 gfc_type_abi_kind (&tsource->ts));
2033 }
2034
2035
2036 void
2037 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
2038 gfc_expr *j ATTRIBUTE_UNUSED,
2039 gfc_expr *mask ATTRIBUTE_UNUSED)
2040 {
2041 f->ts = i->ts;
2042
2043 f->value.function.name
2044 = gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i->ts.type),
2045 i->ts.kind);
2046 }
2047
2048
2049 void
2050 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
2051 {
2052 gfc_resolve_minmax ("__min_%c%d", f, args);
2053 }
2054
2055
2056 void
2057 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2058 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
2059 {
2060 const char *name;
2061 int i, j, idim;
2062 int fkind;
2063 int d_num;
2064
2065 f->ts.type = BT_INTEGER;
2066
2067 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2068 we do a type conversion further down. */
2069 if (kind)
2070 fkind = mpz_get_si (kind->value.integer);
2071 else
2072 fkind = gfc_default_integer_kind;
2073
2074 if (fkind < MINMAXLOC_MIN_KIND)
2075 f->ts.kind = MINMAXLOC_MIN_KIND;
2076 else
2077 f->ts.kind = fkind;
2078
2079 if (dim == NULL)
2080 {
2081 f->rank = 1;
2082 f->shape = gfc_get_shape (1);
2083 mpz_init_set_si (f->shape[0], array->rank);
2084 }
2085 else
2086 {
2087 f->rank = array->rank - 1;
2088 gfc_resolve_dim_arg (dim);
2089 if (array->shape && dim->expr_type == EXPR_CONSTANT)
2090 {
2091 idim = (int) mpz_get_si (dim->value.integer);
2092 f->shape = gfc_get_shape (f->rank);
2093 for (i = 0, j = 0; i < f->rank; i++, j++)
2094 {
2095 if (i == (idim - 1))
2096 j++;
2097 mpz_init_set (f->shape[i], array->shape[j]);
2098 }
2099 }
2100 }
2101
2102 if (mask)
2103 {
2104 if (mask->rank == 0)
2105 name = "sminloc";
2106 else
2107 name = "mminloc";
2108
2109 resolve_mask_arg (mask);
2110 }
2111 else
2112 name = "minloc";
2113
2114 if (dim)
2115 {
2116 if (array->ts.type != BT_CHARACTER || f->rank != 0)
2117 d_num = 1;
2118 else
2119 d_num = 2;
2120 }
2121 else
2122 d_num = 0;
2123
2124 f->value.function.name
2125 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2126 gfc_type_letter (array->ts.type),
2127 gfc_type_abi_kind (&array->ts));
2128
2129 if (fkind != f->ts.kind)
2130 {
2131 gfc_typespec ts;
2132 gfc_clear_ts (&ts);
2133
2134 ts.type = BT_INTEGER;
2135 ts.kind = fkind;
2136 gfc_convert_type_warn (f, &ts, 2, 0);
2137 }
2138
2139 if (back->ts.kind != gfc_logical_4_kind)
2140 {
2141 gfc_typespec ts;
2142 gfc_clear_ts (&ts);
2143 ts.type = BT_LOGICAL;
2144 ts.kind = gfc_logical_4_kind;
2145 gfc_convert_type_warn (back, &ts, 2, 0);
2146 }
2147 }
2148
2149
2150 void
2151 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2152 gfc_expr *mask)
2153 {
2154 const char *name;
2155 int i, j, idim;
2156
2157 f->ts = array->ts;
2158
2159 if (dim != NULL)
2160 {
2161 f->rank = array->rank - 1;
2162 gfc_resolve_dim_arg (dim);
2163
2164 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2165 {
2166 idim = (int) mpz_get_si (dim->value.integer);
2167 f->shape = gfc_get_shape (f->rank);
2168 for (i = 0, j = 0; i < f->rank; i++, j++)
2169 {
2170 if (i == (idim - 1))
2171 j++;
2172 mpz_init_set (f->shape[i], array->shape[j]);
2173 }
2174 }
2175 }
2176
2177 if (mask)
2178 {
2179 if (mask->rank == 0)
2180 name = "sminval";
2181 else
2182 name = "mminval";
2183
2184 resolve_mask_arg (mask);
2185 }
2186 else
2187 name = "minval";
2188
2189 if (array->ts.type != BT_CHARACTER)
2190 f->value.function.name
2191 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2192 gfc_type_letter (array->ts.type),
2193 gfc_type_abi_kind (&array->ts));
2194 else
2195 f->value.function.name
2196 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2197 gfc_type_letter (array->ts.type),
2198 gfc_type_abi_kind (&array->ts));
2199 }
2200
2201
2202 void
2203 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2204 {
2205 f->ts.type = a->ts.type;
2206 if (p != NULL)
2207 f->ts.kind = gfc_kind_max (a,p);
2208 else
2209 f->ts.kind = a->ts.kind;
2210
2211 if (p != NULL && a->ts.kind != p->ts.kind)
2212 {
2213 if (a->ts.kind == gfc_kind_max (a,p))
2214 gfc_convert_type (p, &a->ts, 2);
2215 else
2216 gfc_convert_type (a, &p->ts, 2);
2217 }
2218
2219 f->value.function.name
2220 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2221 gfc_type_abi_kind (&f->ts));
2222 }
2223
2224
2225 void
2226 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2227 {
2228 f->ts.type = a->ts.type;
2229 if (p != NULL)
2230 f->ts.kind = gfc_kind_max (a,p);
2231 else
2232 f->ts.kind = a->ts.kind;
2233
2234 if (p != NULL && a->ts.kind != p->ts.kind)
2235 {
2236 if (a->ts.kind == gfc_kind_max (a,p))
2237 gfc_convert_type (p, &a->ts, 2);
2238 else
2239 gfc_convert_type (a, &p->ts, 2);
2240 }
2241
2242 f->value.function.name
2243 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2244 gfc_type_abi_kind (&f->ts));
2245 }
2246
2247 void
2248 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2249 {
2250 if (p->ts.kind != a->ts.kind)
2251 gfc_convert_type (p, &a->ts, 2);
2252
2253 f->ts = a->ts;
2254 f->value.function.name
2255 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2256 gfc_type_abi_kind (&a->ts));
2257 }
2258
2259 void
2260 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2261 {
2262 f->ts.type = BT_INTEGER;
2263 f->ts.kind = (kind == NULL)
2264 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2265 f->value.function.name
2266 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2267 }
2268
2269
2270 void
2271 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2272 {
2273 resolve_transformational ("norm2", f, array, dim, NULL);
2274 }
2275
2276
2277 void
2278 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2279 {
2280 f->ts = i->ts;
2281 const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d";
2282 f->value.function.name = gfc_get_string (name, i->ts.kind);
2283 }
2284
2285
2286 void
2287 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2288 {
2289 f->ts.type = i->ts.type;
2290 f->ts.kind = gfc_kind_max (i, j);
2291
2292 if (i->ts.kind != j->ts.kind)
2293 {
2294 if (i->ts.kind == gfc_kind_max (i, j))
2295 gfc_convert_type (j, &i->ts, 2);
2296 else
2297 gfc_convert_type (i, &j->ts, 2);
2298 }
2299
2300 f->value.function.name
2301 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type),
2302 gfc_type_abi_kind (&f->ts));
2303 }
2304
2305
2306 void
2307 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2308 gfc_expr *vector ATTRIBUTE_UNUSED)
2309 {
2310 if (array->ts.type == BT_CHARACTER && array->ref)
2311 gfc_resolve_substring_charlen (array);
2312
2313 f->ts = array->ts;
2314 f->rank = 1;
2315
2316 resolve_mask_arg (mask);
2317
2318 if (mask->rank != 0)
2319 {
2320 if (array->ts.type == BT_CHARACTER)
2321 f->value.function.name
2322 = array->ts.kind == 1 ? PREFIX ("pack_char")
2323 : gfc_get_string
2324 (PREFIX ("pack_char%d"),
2325 array->ts.kind);
2326 else
2327 f->value.function.name = PREFIX ("pack");
2328 }
2329 else
2330 {
2331 if (array->ts.type == BT_CHARACTER)
2332 f->value.function.name
2333 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2334 : gfc_get_string
2335 (PREFIX ("pack_s_char%d"),
2336 array->ts.kind);
2337 else
2338 f->value.function.name = PREFIX ("pack_s");
2339 }
2340 }
2341
2342
2343 void
2344 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2345 {
2346 resolve_transformational ("parity", f, array, dim, NULL);
2347 }
2348
2349
2350 void
2351 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2352 gfc_expr *mask)
2353 {
2354 resolve_transformational ("product", f, array, dim, mask, true);
2355 }
2356
2357
2358 void
2359 gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2360 {
2361 f->ts.type = BT_INTEGER;
2362 f->ts.kind = gfc_default_integer_kind;
2363 f->value.function.name = gfc_get_string ("__rank");
2364 }
2365
2366
2367 void
2368 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2369 {
2370 f->ts.type = BT_REAL;
2371
2372 if (kind != NULL)
2373 f->ts.kind = mpz_get_si (kind->value.integer);
2374 else
2375 f->ts.kind = (a->ts.type == BT_COMPLEX)
2376 ? a->ts.kind : gfc_default_real_kind;
2377
2378 f->value.function.name
2379 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2380 gfc_type_letter (a->ts.type),
2381 gfc_type_abi_kind (&a->ts));
2382 }
2383
2384
2385 void
2386 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2387 {
2388 f->ts.type = BT_REAL;
2389 f->ts.kind = a->ts.kind;
2390 f->value.function.name
2391 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2392 gfc_type_letter (a->ts.type),
2393 gfc_type_abi_kind (&a->ts));
2394 }
2395
2396
2397 void
2398 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2399 gfc_expr *p2 ATTRIBUTE_UNUSED)
2400 {
2401 f->ts.type = BT_INTEGER;
2402 f->ts.kind = gfc_default_integer_kind;
2403 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2404 }
2405
2406
2407 void
2408 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2409 gfc_expr *ncopies)
2410 {
2411 gfc_expr *tmp;
2412 f->ts.type = BT_CHARACTER;
2413 f->ts.kind = string->ts.kind;
2414 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2415
2416 /* If possible, generate a character length. */
2417 if (f->ts.u.cl == NULL)
2418 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2419
2420 tmp = NULL;
2421 if (string->expr_type == EXPR_CONSTANT)
2422 {
2423 tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2424 string->value.character.length);
2425 }
2426 else if (string->ts.u.cl && string->ts.u.cl->length)
2427 {
2428 tmp = gfc_copy_expr (string->ts.u.cl->length);
2429 }
2430
2431 if (tmp)
2432 {
2433 /* Force-convert to gfc_charlen_int_kind before gfc_multiply. */
2434 gfc_expr *e = gfc_copy_expr (ncopies);
2435 gfc_typespec ts = tmp->ts;
2436 ts.kind = gfc_charlen_int_kind;
2437 gfc_convert_type_warn (e, &ts, 2, 0);
2438 gfc_convert_type_warn (tmp, &ts, 2, 0);
2439 f->ts.u.cl->length = gfc_multiply (tmp, e);
2440 }
2441 }
2442
2443
2444 void
2445 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2446 gfc_expr *pad ATTRIBUTE_UNUSED,
2447 gfc_expr *order ATTRIBUTE_UNUSED)
2448 {
2449 mpz_t rank;
2450 int kind;
2451 int i;
2452
2453 if (source->ts.type == BT_CHARACTER && source->ref)
2454 gfc_resolve_substring_charlen (source);
2455
2456 f->ts = source->ts;
2457
2458 gfc_array_size (shape, &rank);
2459 f->rank = mpz_get_si (rank);
2460 mpz_clear (rank);
2461 switch (source->ts.type)
2462 {
2463 case BT_COMPLEX:
2464 case BT_REAL:
2465 case BT_INTEGER:
2466 case BT_LOGICAL:
2467 case BT_CHARACTER:
2468 kind = source->ts.kind;
2469 break;
2470
2471 default:
2472 kind = 0;
2473 break;
2474 }
2475
2476 switch (kind)
2477 {
2478 case 4:
2479 case 8:
2480 case 10:
2481 case 16:
2482 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2483 f->value.function.name
2484 = gfc_get_string (PREFIX ("reshape_%c%d"),
2485 gfc_type_letter (source->ts.type),
2486 gfc_type_abi_kind (&source->ts));
2487 else if (source->ts.type == BT_CHARACTER)
2488 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2489 kind);
2490 else
2491 f->value.function.name
2492 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2493 break;
2494
2495 default:
2496 f->value.function.name = (source->ts.type == BT_CHARACTER
2497 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2498 break;
2499 }
2500
2501 if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2502 {
2503 gfc_constructor *c;
2504 f->shape = gfc_get_shape (f->rank);
2505 c = gfc_constructor_first (shape->value.constructor);
2506 for (i = 0; i < f->rank; i++)
2507 {
2508 mpz_init_set (f->shape[i], c->expr->value.integer);
2509 c = gfc_constructor_next (c);
2510 }
2511 }
2512
2513 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2514 so many runtime variations. */
2515 if (shape->ts.kind != gfc_index_integer_kind)
2516 {
2517 gfc_typespec ts = shape->ts;
2518 ts.kind = gfc_index_integer_kind;
2519 gfc_convert_type_warn (shape, &ts, 2, 0);
2520 }
2521 if (order && order->ts.kind != gfc_index_integer_kind)
2522 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2523 }
2524
2525
2526 void
2527 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2528 {
2529 f->ts = x->ts;
2530 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2531 }
2532
2533 void
2534 gfc_resolve_fe_runtime_error (gfc_code *c)
2535 {
2536 const char *name;
2537 gfc_actual_arglist *a;
2538
2539 name = gfc_get_string (PREFIX ("runtime_error"));
2540
2541 for (a = c->ext.actual->next; a; a = a->next)
2542 a->name = "%VAL";
2543
2544 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2545 /* We set the backend_decl here because runtime_error is a
2546 variadic function and we would use the wrong calling
2547 convention otherwise. */
2548 c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2549 }
2550
2551 void
2552 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2553 {
2554 f->ts = x->ts;
2555 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2556 }
2557
2558
2559 void
2560 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2561 gfc_expr *set ATTRIBUTE_UNUSED,
2562 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2563 {
2564 f->ts.type = BT_INTEGER;
2565 if (kind)
2566 f->ts.kind = mpz_get_si (kind->value.integer);
2567 else
2568 f->ts.kind = gfc_default_integer_kind;
2569 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2570 }
2571
2572
2573 void
2574 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2575 {
2576 t1->ts = t0->ts;
2577 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2578 }
2579
2580
2581 void
2582 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2583 gfc_expr *i ATTRIBUTE_UNUSED)
2584 {
2585 f->ts = x->ts;
2586 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2587 }
2588
2589
2590 void
2591 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2592 {
2593 f->ts.type = BT_INTEGER;
2594
2595 if (kind)
2596 f->ts.kind = mpz_get_si (kind->value.integer);
2597 else
2598 f->ts.kind = gfc_default_integer_kind;
2599
2600 f->rank = 1;
2601 if (array->rank != -1)
2602 {
2603 f->shape = gfc_get_shape (1);
2604 mpz_init_set_ui (f->shape[0], array->rank);
2605 }
2606
2607 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2608 }
2609
2610
2611 void
2612 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2613 {
2614 f->ts = i->ts;
2615 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2616 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2617 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2618 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2619 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2620 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2621 else
2622 gcc_unreachable ();
2623 }
2624
2625
2626 void
2627 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2628 {
2629 f->ts = a->ts;
2630 f->value.function.name
2631 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
2632 gfc_type_abi_kind (&a->ts));
2633 }
2634
2635
2636 void
2637 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2638 {
2639 f->ts.type = BT_INTEGER;
2640 f->ts.kind = gfc_c_int_kind;
2641
2642 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2643 if (handler->ts.type == BT_INTEGER)
2644 {
2645 if (handler->ts.kind != gfc_c_int_kind)
2646 gfc_convert_type (handler, &f->ts, 2);
2647 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2648 }
2649 else
2650 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2651
2652 if (number->ts.kind != gfc_c_int_kind)
2653 gfc_convert_type (number, &f->ts, 2);
2654 }
2655
2656
2657 void
2658 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2659 {
2660 f->ts = x->ts;
2661 f->value.function.name
2662 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2663 gfc_type_abi_kind (&x->ts));
2664 }
2665
2666
2667 void
2668 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2669 {
2670 f->ts = x->ts;
2671 f->value.function.name
2672 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
2673 gfc_type_abi_kind (&x->ts));
2674 }
2675
2676
2677 void
2678 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2679 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2680 {
2681 f->ts.type = BT_INTEGER;
2682 if (kind)
2683 f->ts.kind = mpz_get_si (kind->value.integer);
2684 else
2685 f->ts.kind = gfc_default_integer_kind;
2686 }
2687
2688
2689 void
2690 gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2691 gfc_expr *dim ATTRIBUTE_UNUSED)
2692 {
2693 f->ts.type = BT_INTEGER;
2694 f->ts.kind = gfc_index_integer_kind;
2695 }
2696
2697
2698 void
2699 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2700 {
2701 f->ts = x->ts;
2702 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2703 }
2704
2705
2706 void
2707 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2708 gfc_expr *ncopies)
2709 {
2710 if (source->ts.type == BT_CHARACTER && source->ref)
2711 gfc_resolve_substring_charlen (source);
2712
2713 if (source->ts.type == BT_CHARACTER)
2714 check_charlen_present (source);
2715
2716 f->ts = source->ts;
2717 f->rank = source->rank + 1;
2718 if (source->rank == 0)
2719 {
2720 if (source->ts.type == BT_CHARACTER)
2721 f->value.function.name
2722 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2723 : gfc_get_string
2724 (PREFIX ("spread_char%d_scalar"),
2725 source->ts.kind);
2726 else
2727 f->value.function.name = PREFIX ("spread_scalar");
2728 }
2729 else
2730 {
2731 if (source->ts.type == BT_CHARACTER)
2732 f->value.function.name
2733 = source->ts.kind == 1 ? PREFIX ("spread_char")
2734 : gfc_get_string
2735 (PREFIX ("spread_char%d"),
2736 source->ts.kind);
2737 else
2738 f->value.function.name = PREFIX ("spread");
2739 }
2740
2741 if (dim && gfc_is_constant_expr (dim)
2742 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2743 {
2744 int i, idim;
2745 idim = mpz_get_ui (dim->value.integer);
2746 f->shape = gfc_get_shape (f->rank);
2747 for (i = 0; i < (idim - 1); i++)
2748 mpz_init_set (f->shape[i], source->shape[i]);
2749
2750 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2751
2752 for (i = idim; i < f->rank ; i++)
2753 mpz_init_set (f->shape[i], source->shape[i-1]);
2754 }
2755
2756
2757 gfc_resolve_dim_arg (dim);
2758 gfc_resolve_index (ncopies, 1);
2759 }
2760
2761
2762 void
2763 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2764 {
2765 f->ts = x->ts;
2766 f->value.function.name
2767 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
2768 gfc_type_abi_kind (&x->ts));
2769 }
2770
2771
2772 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2773
2774 void
2775 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2776 gfc_expr *a ATTRIBUTE_UNUSED)
2777 {
2778 f->ts.type = BT_INTEGER;
2779 f->ts.kind = gfc_default_integer_kind;
2780 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2781 }
2782
2783
2784 void
2785 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2786 gfc_expr *a ATTRIBUTE_UNUSED)
2787 {
2788 f->ts.type = BT_INTEGER;
2789 f->ts.kind = gfc_default_integer_kind;
2790 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2791 }
2792
2793
2794 void
2795 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2796 {
2797 f->ts.type = BT_INTEGER;
2798 f->ts.kind = gfc_default_integer_kind;
2799 if (n->ts.kind != f->ts.kind)
2800 gfc_convert_type (n, &f->ts, 2);
2801
2802 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2803 }
2804
2805
2806 void
2807 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2808 {
2809 gfc_typespec ts;
2810 gfc_clear_ts (&ts);
2811
2812 f->ts.type = BT_INTEGER;
2813 f->ts.kind = gfc_c_int_kind;
2814 if (u->ts.kind != gfc_c_int_kind)
2815 {
2816 ts.type = BT_INTEGER;
2817 ts.kind = gfc_c_int_kind;
2818 ts.u.derived = NULL;
2819 ts.u.cl = NULL;
2820 gfc_convert_type (u, &ts, 2);
2821 }
2822
2823 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2824 }
2825
2826
2827 void
2828 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2829 {
2830 f->ts.type = BT_INTEGER;
2831 f->ts.kind = gfc_c_int_kind;
2832 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2833 }
2834
2835
2836 void
2837 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2838 {
2839 gfc_typespec ts;
2840 gfc_clear_ts (&ts);
2841
2842 f->ts.type = BT_INTEGER;
2843 f->ts.kind = gfc_c_int_kind;
2844 if (u->ts.kind != gfc_c_int_kind)
2845 {
2846 ts.type = BT_INTEGER;
2847 ts.kind = gfc_c_int_kind;
2848 ts.u.derived = NULL;
2849 ts.u.cl = NULL;
2850 gfc_convert_type (u, &ts, 2);
2851 }
2852
2853 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2854 }
2855
2856
2857 void
2858 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2859 {
2860 f->ts.type = BT_INTEGER;
2861 f->ts.kind = gfc_c_int_kind;
2862 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2863 }
2864
2865
2866 void
2867 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2868 {
2869 gfc_typespec ts;
2870 gfc_clear_ts (&ts);
2871
2872 f->ts.type = BT_INTEGER;
2873 f->ts.kind = gfc_intio_kind;
2874 if (u->ts.kind != gfc_c_int_kind)
2875 {
2876 ts.type = BT_INTEGER;
2877 ts.kind = gfc_c_int_kind;
2878 ts.u.derived = NULL;
2879 ts.u.cl = NULL;
2880 gfc_convert_type (u, &ts, 2);
2881 }
2882
2883 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2884 }
2885
2886
2887 void
2888 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2889 gfc_expr *kind)
2890 {
2891 f->ts.type = BT_INTEGER;
2892 if (kind)
2893 f->ts.kind = mpz_get_si (kind->value.integer);
2894 else
2895 f->ts.kind = gfc_default_integer_kind;
2896 }
2897
2898
2899 void
2900 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2901 {
2902 resolve_transformational ("sum", f, array, dim, mask, true);
2903 }
2904
2905
2906 void
2907 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2908 gfc_expr *p2 ATTRIBUTE_UNUSED)
2909 {
2910 f->ts.type = BT_INTEGER;
2911 f->ts.kind = gfc_default_integer_kind;
2912 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2913 }
2914
2915
2916 /* Resolve the g77 compatibility function SYSTEM. */
2917
2918 void
2919 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2920 {
2921 f->ts.type = BT_INTEGER;
2922 f->ts.kind = 4;
2923 f->value.function.name = gfc_get_string (PREFIX ("system"));
2924 }
2925
2926
2927 void
2928 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2929 {
2930 f->ts = x->ts;
2931 f->value.function.name
2932 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
2933 gfc_type_abi_kind (&x->ts));
2934 }
2935
2936
2937 void
2938 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2939 {
2940 f->ts = x->ts;
2941 f->value.function.name
2942 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
2943 gfc_type_abi_kind (&x->ts));
2944 }
2945
2946
2947 /* Resolve failed_images (team, kind). */
2948
2949 void
2950 gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2951 gfc_expr *kind)
2952 {
2953 static char failed_images[] = "_gfortran_caf_failed_images";
2954 f->rank = 1;
2955 f->ts.type = BT_INTEGER;
2956 if (kind == NULL)
2957 f->ts.kind = gfc_default_integer_kind;
2958 else
2959 gfc_extract_int (kind, &f->ts.kind);
2960 f->value.function.name = failed_images;
2961 }
2962
2963
2964 /* Resolve image_status (image, team). */
2965
2966 void
2967 gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2968 gfc_expr *team ATTRIBUTE_UNUSED)
2969 {
2970 static char image_status[] = "_gfortran_caf_image_status";
2971 f->ts.type = BT_INTEGER;
2972 f->ts.kind = gfc_default_integer_kind;
2973 f->value.function.name = image_status;
2974 }
2975
2976
2977 /* Resolve get_team (). */
2978
2979 void
2980 gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2981 {
2982 static char get_team[] = "_gfortran_caf_get_team";
2983 f->rank = 0;
2984 f->ts.type = BT_INTEGER;
2985 f->ts.kind = gfc_default_integer_kind;
2986 f->value.function.name = get_team;
2987 }
2988
2989
2990 /* Resolve image_index (...). */
2991
2992 void
2993 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2994 gfc_expr *sub ATTRIBUTE_UNUSED)
2995 {
2996 static char image_index[] = "__image_index";
2997 f->ts.type = BT_INTEGER;
2998 f->ts.kind = gfc_default_integer_kind;
2999 f->value.function.name = image_index;
3000 }
3001
3002
3003 /* Resolve stopped_images (team, kind). */
3004
3005 void
3006 gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
3007 gfc_expr *kind)
3008 {
3009 static char stopped_images[] = "_gfortran_caf_stopped_images";
3010 f->rank = 1;
3011 f->ts.type = BT_INTEGER;
3012 if (kind == NULL)
3013 f->ts.kind = gfc_default_integer_kind;
3014 else
3015 gfc_extract_int (kind, &f->ts.kind);
3016 f->value.function.name = stopped_images;
3017 }
3018
3019
3020 /* Resolve team_number (team). */
3021
3022 void
3023 gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
3024 {
3025 static char team_number[] = "_gfortran_caf_team_number";
3026 f->rank = 0;
3027 f->ts.type = BT_INTEGER;
3028 f->ts.kind = gfc_default_integer_kind;
3029 f->value.function.name = team_number;
3030 }
3031
3032
3033 void
3034 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
3035 gfc_expr *distance ATTRIBUTE_UNUSED)
3036 {
3037 static char this_image[] = "__this_image";
3038 if (array && gfc_is_coarray (array))
3039 resolve_bound (f, array, dim, NULL, "__this_image", true);
3040 else
3041 {
3042 f->ts.type = BT_INTEGER;
3043 f->ts.kind = gfc_default_integer_kind;
3044 f->value.function.name = this_image;
3045 }
3046 }
3047
3048
3049 void
3050 gfc_resolve_time (gfc_expr *f)
3051 {
3052 f->ts.type = BT_INTEGER;
3053 f->ts.kind = 4;
3054 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
3055 }
3056
3057
3058 void
3059 gfc_resolve_time8 (gfc_expr *f)
3060 {
3061 f->ts.type = BT_INTEGER;
3062 f->ts.kind = 8;
3063 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
3064 }
3065
3066
3067 void
3068 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
3069 gfc_expr *mold, gfc_expr *size)
3070 {
3071 /* TODO: Make this do something meaningful. */
3072 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3073
3074 if (mold->ts.type == BT_CHARACTER
3075 && !mold->ts.u.cl->length
3076 && gfc_is_constant_expr (mold))
3077 {
3078 int len;
3079 if (mold->expr_type == EXPR_CONSTANT)
3080 {
3081 len = mold->value.character.length;
3082 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3083 NULL, len);
3084 }
3085 else
3086 {
3087 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3088 len = c->expr->value.character.length;
3089 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3090 NULL, len);
3091 }
3092 }
3093
3094 if (UNLIMITED_POLY (mold))
3095 gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3096 &mold->where);
3097
3098 f->ts = mold->ts;
3099
3100 if (size == NULL && mold->rank == 0)
3101 {
3102 f->rank = 0;
3103 f->value.function.name = transfer0;
3104 }
3105 else
3106 {
3107 f->rank = 1;
3108 f->value.function.name = transfer1;
3109 if (size && gfc_is_constant_expr (size))
3110 {
3111 f->shape = gfc_get_shape (1);
3112 mpz_init_set (f->shape[0], size->value.integer);
3113 }
3114 }
3115 }
3116
3117
3118 void
3119 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3120 {
3121
3122 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3123 gfc_resolve_substring_charlen (matrix);
3124
3125 f->ts = matrix->ts;
3126 f->rank = 2;
3127 if (matrix->shape)
3128 {
3129 f->shape = gfc_get_shape (2);
3130 mpz_init_set (f->shape[0], matrix->shape[1]);
3131 mpz_init_set (f->shape[1], matrix->shape[0]);
3132 }
3133
3134 switch (matrix->ts.kind)
3135 {
3136 case 4:
3137 case 8:
3138 case 10:
3139 case 16:
3140 switch (matrix->ts.type)
3141 {
3142 case BT_REAL:
3143 case BT_COMPLEX:
3144 f->value.function.name
3145 = gfc_get_string (PREFIX ("transpose_%c%d"),
3146 gfc_type_letter (matrix->ts.type),
3147 gfc_type_abi_kind (&matrix->ts));
3148 break;
3149
3150 case BT_INTEGER:
3151 case BT_LOGICAL:
3152 /* Use the integer routines for real and logical cases. This
3153 assumes they all have the same alignment requirements. */
3154 f->value.function.name
3155 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3156 break;
3157
3158 default:
3159 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3160 f->value.function.name = PREFIX ("transpose_char4");
3161 else
3162 f->value.function.name = PREFIX ("transpose");
3163 break;
3164 }
3165 break;
3166
3167 default:
3168 f->value.function.name = (matrix->ts.type == BT_CHARACTER
3169 ? PREFIX ("transpose_char")
3170 : PREFIX ("transpose"));
3171 break;
3172 }
3173 }
3174
3175
3176 void
3177 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3178 {
3179 f->ts.type = BT_CHARACTER;
3180 f->ts.kind = string->ts.kind;
3181 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3182 }
3183
3184
3185 /* Resolve the degree trigonometric functions. This amounts to setting
3186 the function return type-spec from its argument and building a
3187 library function names of the form _gfortran_sind_r4. */
3188
3189 void
3190 gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3191 {
3192 f->ts = x->ts;
3193 f->value.function.name
3194 = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3195 gfc_type_letter (x->ts.type),
3196 gfc_type_abi_kind (&x->ts));
3197 }
3198
3199
3200 void
3201 gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3202 {
3203 f->ts = y->ts;
3204 f->value.function.name
3205 = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3206 x->ts.kind);
3207 }
3208
3209
3210 void
3211 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3212 {
3213 resolve_bound (f, array, dim, kind, "__ubound", false);
3214 }
3215
3216
3217 void
3218 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3219 {
3220 resolve_bound (f, array, dim, kind, "__ucobound", true);
3221 }
3222
3223
3224 /* Resolve the g77 compatibility function UMASK. */
3225
3226 void
3227 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3228 {
3229 f->ts.type = BT_INTEGER;
3230 f->ts.kind = n->ts.kind;
3231 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3232 }
3233
3234
3235 /* Resolve the g77 compatibility function UNLINK. */
3236
3237 void
3238 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3239 {
3240 f->ts.type = BT_INTEGER;
3241 f->ts.kind = 4;
3242 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3243 }
3244
3245
3246 void
3247 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3248 {
3249 gfc_typespec ts;
3250 gfc_clear_ts (&ts);
3251
3252 f->ts.type = BT_CHARACTER;
3253 f->ts.kind = gfc_default_character_kind;
3254
3255 if (unit->ts.kind != gfc_c_int_kind)
3256 {
3257 ts.type = BT_INTEGER;
3258 ts.kind = gfc_c_int_kind;
3259 ts.u.derived = NULL;
3260 ts.u.cl = NULL;
3261 gfc_convert_type (unit, &ts, 2);
3262 }
3263
3264 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3265 }
3266
3267
3268 void
3269 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3270 gfc_expr *field ATTRIBUTE_UNUSED)
3271 {
3272 if (vector->ts.type == BT_CHARACTER && vector->ref)
3273 gfc_resolve_substring_charlen (vector);
3274
3275 f->ts = vector->ts;
3276 f->rank = mask->rank;
3277 resolve_mask_arg (mask);
3278
3279 if (vector->ts.type == BT_CHARACTER)
3280 {
3281 if (vector->ts.kind == 1)
3282 f->value.function.name
3283 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3284 else
3285 f->value.function.name
3286 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3287 field->rank > 0 ? 1 : 0, vector->ts.kind);
3288 }
3289 else
3290 f->value.function.name
3291 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3292 }
3293
3294
3295 void
3296 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3297 gfc_expr *set ATTRIBUTE_UNUSED,
3298 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3299 {
3300 f->ts.type = BT_INTEGER;
3301 if (kind)
3302 f->ts.kind = mpz_get_si (kind->value.integer);
3303 else
3304 f->ts.kind = gfc_default_integer_kind;
3305 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3306 }
3307
3308
3309 void
3310 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3311 {
3312 f->ts.type = i->ts.type;
3313 f->ts.kind = gfc_kind_max (i, j);
3314
3315 if (i->ts.kind != j->ts.kind)
3316 {
3317 if (i->ts.kind == gfc_kind_max (i, j))
3318 gfc_convert_type (j, &i->ts, 2);
3319 else
3320 gfc_convert_type (i, &j->ts, 2);
3321 }
3322
3323 f->value.function.name
3324 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3325 gfc_type_abi_kind (&f->ts));
3326 }
3327
3328
3329 /* Intrinsic subroutine resolution. */
3330
3331 void
3332 gfc_resolve_alarm_sub (gfc_code *c)
3333 {
3334 const char *name;
3335 gfc_expr *seconds, *handler;
3336 gfc_typespec ts;
3337 gfc_clear_ts (&ts);
3338
3339 seconds = c->ext.actual->expr;
3340 handler = c->ext.actual->next->expr;
3341 ts.type = BT_INTEGER;
3342 ts.kind = gfc_c_int_kind;
3343
3344 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3345 In all cases, the status argument is of default integer kind
3346 (enforced in check.cc) so that the function suffix is fixed. */
3347 if (handler->ts.type == BT_INTEGER)
3348 {
3349 if (handler->ts.kind != gfc_c_int_kind)
3350 gfc_convert_type (handler, &ts, 2);
3351 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3352 gfc_default_integer_kind);
3353 }
3354 else
3355 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3356 gfc_default_integer_kind);
3357
3358 if (seconds->ts.kind != gfc_c_int_kind)
3359 gfc_convert_type (seconds, &ts, 2);
3360
3361 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3362 }
3363
3364 void
3365 gfc_resolve_cpu_time (gfc_code *c)
3366 {
3367 const char *name;
3368 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3369 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3370 }
3371
3372
3373 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3374
3375 static gfc_formal_arglist*
3376 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3377 {
3378 gfc_formal_arglist* head;
3379 gfc_formal_arglist* tail;
3380 int i;
3381
3382 if (!actual)
3383 return NULL;
3384
3385 head = tail = gfc_get_formal_arglist ();
3386 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3387 {
3388 gfc_symbol* sym;
3389
3390 sym = gfc_new_symbol ("dummyarg", NULL);
3391 sym->ts = actual->expr->ts;
3392
3393 sym->attr.intent = ints[i];
3394 tail->sym = sym;
3395
3396 if (actual->next)
3397 tail->next = gfc_get_formal_arglist ();
3398 }
3399
3400 return head;
3401 }
3402
3403
3404 void
3405 gfc_resolve_atomic_def (gfc_code *c)
3406 {
3407 const char *name = "atomic_define";
3408 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3409 }
3410
3411
3412 void
3413 gfc_resolve_atomic_ref (gfc_code *c)
3414 {
3415 const char *name = "atomic_ref";
3416 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3417 }
3418
3419 void
3420 gfc_resolve_event_query (gfc_code *c)
3421 {
3422 const char *name = "event_query";
3423 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3424 }
3425
3426 void
3427 gfc_resolve_mvbits (gfc_code *c)
3428 {
3429 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3430 INTENT_INOUT, INTENT_IN};
3431 const char *name;
3432
3433 /* TO and FROM are guaranteed to have the same kind parameter. */
3434 name = gfc_get_string (PREFIX ("mvbits_i%d"),
3435 c->ext.actual->expr->ts.kind);
3436 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3437 /* Mark as elemental subroutine as this does not happen automatically. */
3438 c->resolved_sym->attr.elemental = 1;
3439
3440 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3441 of creating temporaries. */
3442 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3443 }
3444
3445
3446 /* Set up the call to RANDOM_INIT. */
3447
3448 void
3449 gfc_resolve_random_init (gfc_code *c)
3450 {
3451 const char *name;
3452 name = gfc_get_string (PREFIX ("random_init"));
3453 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3454 }
3455
3456
3457 void
3458 gfc_resolve_random_number (gfc_code *c)
3459 {
3460 const char *name;
3461 int kind;
3462 char type;
3463
3464 kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3465 type = gfc_type_letter (c->ext.actual->expr->ts.type);
3466 if (c->ext.actual->expr->rank == 0)
3467 name = gfc_get_string (PREFIX ("random_%c%d"), type, kind);
3468 else
3469 name = gfc_get_string (PREFIX ("arandom_%c%d"), type, kind);
3470
3471 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3472 }
3473
3474
3475 void
3476 gfc_resolve_random_seed (gfc_code *c)
3477 {
3478 const char *name;
3479
3480 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3481 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3482 }
3483
3484
3485 void
3486 gfc_resolve_rename_sub (gfc_code *c)
3487 {
3488 const char *name;
3489 int kind;
3490
3491 /* Find the type of status. If not present use default integer kind. */
3492 if (c->ext.actual->next->next->expr != NULL)
3493 kind = c->ext.actual->next->next->expr->ts.kind;
3494 else
3495 kind = gfc_default_integer_kind;
3496
3497 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3498 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3499 }
3500
3501
3502 void
3503 gfc_resolve_link_sub (gfc_code *c)
3504 {
3505 const char *name;
3506 int kind;
3507
3508 if (c->ext.actual->next->next->expr != NULL)
3509 kind = c->ext.actual->next->next->expr->ts.kind;
3510 else
3511 kind = gfc_default_integer_kind;
3512
3513 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3514 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3515 }
3516
3517
3518 void
3519 gfc_resolve_symlnk_sub (gfc_code *c)
3520 {
3521 const char *name;
3522 int kind;
3523
3524 if (c->ext.actual->next->next->expr != NULL)
3525 kind = c->ext.actual->next->next->expr->ts.kind;
3526 else
3527 kind = gfc_default_integer_kind;
3528
3529 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3530 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3531 }
3532
3533
3534 /* G77 compatibility subroutines dtime() and etime(). */
3535
3536 void
3537 gfc_resolve_dtime_sub (gfc_code *c)
3538 {
3539 const char *name;
3540 name = gfc_get_string (PREFIX ("dtime_sub"));
3541 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3542 }
3543
3544 void
3545 gfc_resolve_etime_sub (gfc_code *c)
3546 {
3547 const char *name;
3548 name = gfc_get_string (PREFIX ("etime_sub"));
3549 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3550 }
3551
3552
3553 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3554
3555 void
3556 gfc_resolve_itime (gfc_code *c)
3557 {
3558 c->resolved_sym
3559 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3560 gfc_default_integer_kind));
3561 }
3562
3563 void
3564 gfc_resolve_idate (gfc_code *c)
3565 {
3566 c->resolved_sym
3567 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3568 gfc_default_integer_kind));
3569 }
3570
3571 void
3572 gfc_resolve_ltime (gfc_code *c)
3573 {
3574 c->resolved_sym
3575 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3576 gfc_default_integer_kind));
3577 }
3578
3579 void
3580 gfc_resolve_gmtime (gfc_code *c)
3581 {
3582 c->resolved_sym
3583 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3584 gfc_default_integer_kind));
3585 }
3586
3587
3588 /* G77 compatibility subroutine second(). */
3589
3590 void
3591 gfc_resolve_second_sub (gfc_code *c)
3592 {
3593 const char *name;
3594 name = gfc_get_string (PREFIX ("second_sub"));
3595 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3596 }
3597
3598
3599 void
3600 gfc_resolve_sleep_sub (gfc_code *c)
3601 {
3602 const char *name;
3603 int kind;
3604
3605 if (c->ext.actual->expr != NULL)
3606 kind = c->ext.actual->expr->ts.kind;
3607 else
3608 kind = gfc_default_integer_kind;
3609
3610 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3611 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3612 }
3613
3614
3615 /* G77 compatibility function srand(). */
3616
3617 void
3618 gfc_resolve_srand (gfc_code *c)
3619 {
3620 const char *name;
3621 name = gfc_get_string (PREFIX ("srand"));
3622 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3623 }
3624
3625
3626 /* Resolve the getarg intrinsic subroutine. */
3627
3628 void
3629 gfc_resolve_getarg (gfc_code *c)
3630 {
3631 const char *name;
3632
3633 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3634 {
3635 gfc_typespec ts;
3636 gfc_clear_ts (&ts);
3637
3638 ts.type = BT_INTEGER;
3639 ts.kind = gfc_default_integer_kind;
3640
3641 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3642 }
3643
3644 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3645 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3646 }
3647
3648
3649 /* Resolve the getcwd intrinsic subroutine. */
3650
3651 void
3652 gfc_resolve_getcwd_sub (gfc_code *c)
3653 {
3654 const char *name;
3655 int kind;
3656
3657 if (c->ext.actual->next->expr != NULL)
3658 kind = c->ext.actual->next->expr->ts.kind;
3659 else
3660 kind = gfc_default_integer_kind;
3661
3662 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3663 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3664 }
3665
3666
3667 /* Resolve the get_command intrinsic subroutine. */
3668
3669 void
3670 gfc_resolve_get_command (gfc_code *c)
3671 {
3672 const char *name;
3673 int kind;
3674 kind = gfc_default_integer_kind;
3675 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3676 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3677 }
3678
3679
3680 /* Resolve the get_command_argument intrinsic subroutine. */
3681
3682 void
3683 gfc_resolve_get_command_argument (gfc_code *c)
3684 {
3685 const char *name;
3686 int kind;
3687 kind = gfc_default_integer_kind;
3688 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3689 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3690 }
3691
3692
3693 /* Resolve the get_environment_variable intrinsic subroutine. */
3694
3695 void
3696 gfc_resolve_get_environment_variable (gfc_code *code)
3697 {
3698 const char *name;
3699 int kind;
3700 kind = gfc_default_integer_kind;
3701 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3702 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3703 }
3704
3705
3706 void
3707 gfc_resolve_signal_sub (gfc_code *c)
3708 {
3709 const char *name;
3710 gfc_expr *number, *handler, *status;
3711 gfc_typespec ts;
3712 gfc_clear_ts (&ts);
3713
3714 number = c->ext.actual->expr;
3715 handler = c->ext.actual->next->expr;
3716 status = c->ext.actual->next->next->expr;
3717 ts.type = BT_INTEGER;
3718 ts.kind = gfc_c_int_kind;
3719
3720 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3721 if (handler->ts.type == BT_INTEGER)
3722 {
3723 if (handler->ts.kind != gfc_c_int_kind)
3724 gfc_convert_type (handler, &ts, 2);
3725 name = gfc_get_string (PREFIX ("signal_sub_int"));
3726 }
3727 else
3728 name = gfc_get_string (PREFIX ("signal_sub"));
3729
3730 if (number->ts.kind != gfc_c_int_kind)
3731 gfc_convert_type (number, &ts, 2);
3732 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3733 gfc_convert_type (status, &ts, 2);
3734
3735 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3736 }
3737
3738
3739 /* Resolve the SYSTEM intrinsic subroutine. */
3740
3741 void
3742 gfc_resolve_system_sub (gfc_code *c)
3743 {
3744 const char *name;
3745 name = gfc_get_string (PREFIX ("system_sub"));
3746 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3747 }
3748
3749
3750 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3751
3752 void
3753 gfc_resolve_system_clock (gfc_code *c)
3754 {
3755 const char *name;
3756 int kind;
3757 gfc_expr *count = c->ext.actual->expr;
3758 gfc_expr *count_max = c->ext.actual->next->next->expr;
3759
3760 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3761 and COUNT_MAX can hold 64-bit values, or are absent. */
3762 if ((!count || count->ts.kind >= 8)
3763 && (!count_max || count_max->ts.kind >= 8))
3764 kind = 8;
3765 else
3766 kind = gfc_default_integer_kind;
3767
3768 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3769 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3770 }
3771
3772
3773 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3774 void
3775 gfc_resolve_execute_command_line (gfc_code *c)
3776 {
3777 const char *name;
3778 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3779 gfc_default_integer_kind);
3780 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3781 }
3782
3783
3784 /* Resolve the EXIT intrinsic subroutine. */
3785
3786 void
3787 gfc_resolve_exit (gfc_code *c)
3788 {
3789 const char *name;
3790 gfc_typespec ts;
3791 gfc_expr *n;
3792 gfc_clear_ts (&ts);
3793
3794 /* The STATUS argument has to be of default kind. If it is not,
3795 we convert it. */
3796 ts.type = BT_INTEGER;
3797 ts.kind = gfc_default_integer_kind;
3798 n = c->ext.actual->expr;
3799 if (n != NULL && n->ts.kind != ts.kind)
3800 gfc_convert_type (n, &ts, 2);
3801
3802 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3803 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3804 }
3805
3806
3807 /* Resolve the FLUSH intrinsic subroutine. */
3808
3809 void
3810 gfc_resolve_flush (gfc_code *c)
3811 {
3812 const char *name;
3813 gfc_typespec ts;
3814 gfc_expr *n;
3815 gfc_clear_ts (&ts);
3816
3817 ts.type = BT_INTEGER;
3818 ts.kind = gfc_default_integer_kind;
3819 n = c->ext.actual->expr;
3820 if (n != NULL && n->ts.kind != ts.kind)
3821 gfc_convert_type (n, &ts, 2);
3822
3823 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3824 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3825 }
3826
3827
3828 void
3829 gfc_resolve_ctime_sub (gfc_code *c)
3830 {
3831 gfc_typespec ts;
3832 gfc_clear_ts (&ts);
3833
3834 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3835 if (c->ext.actual->expr->ts.kind != 8)
3836 {
3837 ts.type = BT_INTEGER;
3838 ts.kind = 8;
3839 ts.u.derived = NULL;
3840 ts.u.cl = NULL;
3841 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3842 }
3843
3844 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3845 }
3846
3847
3848 void
3849 gfc_resolve_fdate_sub (gfc_code *c)
3850 {
3851 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3852 }
3853
3854
3855 void
3856 gfc_resolve_gerror (gfc_code *c)
3857 {
3858 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3859 }
3860
3861
3862 void
3863 gfc_resolve_getlog (gfc_code *c)
3864 {
3865 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3866 }
3867
3868
3869 void
3870 gfc_resolve_hostnm_sub (gfc_code *c)
3871 {
3872 const char *name;
3873 int kind;
3874
3875 if (c->ext.actual->next->expr != NULL)
3876 kind = c->ext.actual->next->expr->ts.kind;
3877 else
3878 kind = gfc_default_integer_kind;
3879
3880 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3881 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3882 }
3883
3884
3885 void
3886 gfc_resolve_perror (gfc_code *c)
3887 {
3888 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3889 }
3890
3891 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3892
3893 void
3894 gfc_resolve_stat_sub (gfc_code *c)
3895 {
3896 const char *name;
3897 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3898 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3899 }
3900
3901
3902 void
3903 gfc_resolve_lstat_sub (gfc_code *c)
3904 {
3905 const char *name;
3906 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3907 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3908 }
3909
3910
3911 void
3912 gfc_resolve_fstat_sub (gfc_code *c)
3913 {
3914 const char *name;
3915 gfc_expr *u;
3916 gfc_typespec *ts;
3917
3918 u = c->ext.actual->expr;
3919 ts = &c->ext.actual->next->expr->ts;
3920 if (u->ts.kind != ts->kind)
3921 gfc_convert_type (u, ts, 2);
3922 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3923 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3924 }
3925
3926
3927 void
3928 gfc_resolve_fgetc_sub (gfc_code *c)
3929 {
3930 const char *name;
3931 gfc_typespec ts;
3932 gfc_expr *u, *st;
3933 gfc_clear_ts (&ts);
3934
3935 u = c->ext.actual->expr;
3936 st = c->ext.actual->next->next->expr;
3937
3938 if (u->ts.kind != gfc_c_int_kind)
3939 {
3940 ts.type = BT_INTEGER;
3941 ts.kind = gfc_c_int_kind;
3942 ts.u.derived = NULL;
3943 ts.u.cl = NULL;
3944 gfc_convert_type (u, &ts, 2);
3945 }
3946
3947 if (st != NULL)
3948 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3949 else
3950 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3951
3952 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3953 }
3954
3955
3956 void
3957 gfc_resolve_fget_sub (gfc_code *c)
3958 {
3959 const char *name;
3960 gfc_expr *st;
3961
3962 st = c->ext.actual->next->expr;
3963 if (st != NULL)
3964 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3965 else
3966 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3967
3968 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3969 }
3970
3971
3972 void
3973 gfc_resolve_fputc_sub (gfc_code *c)
3974 {
3975 const char *name;
3976 gfc_typespec ts;
3977 gfc_expr *u, *st;
3978 gfc_clear_ts (&ts);
3979
3980 u = c->ext.actual->expr;
3981 st = c->ext.actual->next->next->expr;
3982
3983 if (u->ts.kind != gfc_c_int_kind)
3984 {
3985 ts.type = BT_INTEGER;
3986 ts.kind = gfc_c_int_kind;
3987 ts.u.derived = NULL;
3988 ts.u.cl = NULL;
3989 gfc_convert_type (u, &ts, 2);
3990 }
3991
3992 if (st != NULL)
3993 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3994 else
3995 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3996
3997 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3998 }
3999
4000
4001 void
4002 gfc_resolve_fput_sub (gfc_code *c)
4003 {
4004 const char *name;
4005 gfc_expr *st;
4006
4007 st = c->ext.actual->next->expr;
4008 if (st != NULL)
4009 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
4010 else
4011 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
4012
4013 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4014 }
4015
4016
4017 void
4018 gfc_resolve_fseek_sub (gfc_code *c)
4019 {
4020 gfc_expr *unit;
4021 gfc_expr *offset;
4022 gfc_expr *whence;
4023 gfc_typespec ts;
4024 gfc_clear_ts (&ts);
4025
4026 unit = c->ext.actual->expr;
4027 offset = c->ext.actual->next->expr;
4028 whence = c->ext.actual->next->next->expr;
4029
4030 if (unit->ts.kind != gfc_c_int_kind)
4031 {
4032 ts.type = BT_INTEGER;
4033 ts.kind = gfc_c_int_kind;
4034 ts.u.derived = NULL;
4035 ts.u.cl = NULL;
4036 gfc_convert_type (unit, &ts, 2);
4037 }
4038
4039 if (offset->ts.kind != gfc_intio_kind)
4040 {
4041 ts.type = BT_INTEGER;
4042 ts.kind = gfc_intio_kind;
4043 ts.u.derived = NULL;
4044 ts.u.cl = NULL;
4045 gfc_convert_type (offset, &ts, 2);
4046 }
4047
4048 if (whence->ts.kind != gfc_c_int_kind)
4049 {
4050 ts.type = BT_INTEGER;
4051 ts.kind = gfc_c_int_kind;
4052 ts.u.derived = NULL;
4053 ts.u.cl = NULL;
4054 gfc_convert_type (whence, &ts, 2);
4055 }
4056
4057 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4058 }
4059
4060 void
4061 gfc_resolve_ftell_sub (gfc_code *c)
4062 {
4063 const char *name;
4064 gfc_expr *unit;
4065 gfc_expr *offset;
4066 gfc_typespec ts;
4067 gfc_clear_ts (&ts);
4068
4069 unit = c->ext.actual->expr;
4070 offset = c->ext.actual->next->expr;
4071
4072 if (unit->ts.kind != gfc_c_int_kind)
4073 {
4074 ts.type = BT_INTEGER;
4075 ts.kind = gfc_c_int_kind;
4076 ts.u.derived = NULL;
4077 ts.u.cl = NULL;
4078 gfc_convert_type (unit, &ts, 2);
4079 }
4080
4081 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4082 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4083 }
4084
4085
4086 void
4087 gfc_resolve_ttynam_sub (gfc_code *c)
4088 {
4089 gfc_typespec ts;
4090 gfc_clear_ts (&ts);
4091
4092 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4093 {
4094 ts.type = BT_INTEGER;
4095 ts.kind = gfc_c_int_kind;
4096 ts.u.derived = NULL;
4097 ts.u.cl = NULL;
4098 gfc_convert_type (c->ext.actual->expr, &ts, 2);
4099 }
4100
4101 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4102 }
4103
4104
4105 /* Resolve the UMASK intrinsic subroutine. */
4106
4107 void
4108 gfc_resolve_umask_sub (gfc_code *c)
4109 {
4110 const char *name;
4111 int kind;
4112
4113 if (c->ext.actual->next->expr != NULL)
4114 kind = c->ext.actual->next->expr->ts.kind;
4115 else
4116 kind = gfc_default_integer_kind;
4117
4118 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4119 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4120 }
4121
4122 /* Resolve the UNLINK intrinsic subroutine. */
4123
4124 void
4125 gfc_resolve_unlink_sub (gfc_code *c)
4126 {
4127 const char *name;
4128 int kind;
4129
4130 if (c->ext.actual->next->expr != NULL)
4131 kind = c->ext.actual->next->expr->ts.kind;
4132 else
4133 kind = gfc_default_integer_kind;
4134
4135 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4136 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4137 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org