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