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