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