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