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