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