?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR other/30182
[official-gcc.git] / gcc / fortran / iresolve.c
blob4ded73d530765d9314eb9af967443fe366535167
1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA. */
22
23
24 /* Assign name and types to intrinsic procedures. For functions, the
25 first argument to a resolution function is an expression pointer to
26 the original function node and the rest are pointers to the
27 arguments of the function call. For subroutines, a pointer to the
28 code node is passed. The result type and library subroutine name
29 are generally set according to the function arguments. */
30
31 #include "config.h"
32 #include "system.h"
33 #include "coretypes.h"
34 #include "tree.h"
35 #include "gfortran.h"
36 #include "intrinsic.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->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
67 {
68 source->ts.cl = gfc_get_charlen ();
69 source->ts.cl->next = gfc_current_ns->cl_list;
70 gfc_current_ns->cl_list = source->ts.cl;
71 source->ts.cl->length = gfc_int_expr (source->value.character.length);
72 source->rank = 0;
73 }
74 }
75
76 /********************** Resolution functions **********************/
77
78
79 void
80 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
81 {
82 f->ts = a->ts;
83 if (f->ts.type == BT_COMPLEX)
84 f->ts.type = BT_REAL;
85
86 f->value.function.name
87 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
88 }
89
90
91 void
92 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
93 gfc_expr *mode ATTRIBUTE_UNUSED)
94 {
95 f->ts.type = BT_INTEGER;
96 f->ts.kind = gfc_c_int_kind;
97 f->value.function.name = PREFIX ("access_func");
98 }
99
100
101 void
102 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
103 {
104 f->ts = x->ts;
105 f->value.function.name
106 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
107 }
108
109
110 void
111 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
112 {
113 f->ts = x->ts;
114 f->value.function.name
115 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
116 x->ts.kind);
117 }
118
119
120 void
121 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
122 {
123 f->ts.type = BT_REAL;
124 f->ts.kind = x->ts.kind;
125 f->value.function.name
126 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
127 x->ts.kind);
128 }
129
130
131 void
132 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
133 {
134 f->ts.type = i->ts.type;
135 f->ts.kind = gfc_kind_max (i, j);
136
137 if (i->ts.kind != j->ts.kind)
138 {
139 if (i->ts.kind == gfc_kind_max (i, j))
140 gfc_convert_type (j, &i->ts, 2);
141 else
142 gfc_convert_type (i, &j->ts, 2);
143 }
144
145 f->value.function.name
146 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
147 }
148
149
150 void
151 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
152 {
153 gfc_typespec ts;
154
155 f->ts.type = a->ts.type;
156 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
157
158 if (a->ts.kind != f->ts.kind)
159 {
160 ts.type = f->ts.type;
161 ts.kind = f->ts.kind;
162 gfc_convert_type (a, &ts, 2);
163 }
164 /* The resolved name is only used for specific intrinsics where
165 the return kind is the same as the arg kind. */
166 f->value.function.name
167 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
168 }
169
170
171 void
172 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
173 {
174 gfc_resolve_aint (f, a, NULL);
175 }
176
177
178 void
179 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
180 {
181 f->ts = mask->ts;
182
183 if (dim != NULL)
184 {
185 gfc_resolve_dim_arg (dim);
186 f->rank = mask->rank - 1;
187 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
188 }
189
190 f->value.function.name
191 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
192 mask->ts.kind);
193 }
194
195
196 void
197 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
198 {
199 gfc_typespec ts;
200
201 f->ts.type = a->ts.type;
202 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
203
204 if (a->ts.kind != f->ts.kind)
205 {
206 ts.type = f->ts.type;
207 ts.kind = f->ts.kind;
208 gfc_convert_type (a, &ts, 2);
209 }
210
211 /* The resolved name is only used for specific intrinsics where
212 the return kind is the same as the arg kind. */
213 f->value.function.name
214 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
215 a->ts.kind);
216 }
217
218
219 void
220 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
221 {
222 gfc_resolve_anint (f, a, NULL);
223 }
224
225
226 void
227 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
228 {
229 f->ts = mask->ts;
230
231 if (dim != NULL)
232 {
233 gfc_resolve_dim_arg (dim);
234 f->rank = mask->rank - 1;
235 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
236 }
237
238 f->value.function.name
239 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
240 mask->ts.kind);
241 }
242
243
244 void
245 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
246 {
247 f->ts = x->ts;
248 f->value.function.name
249 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
250 }
251
252 void
253 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
254 {
255 f->ts = x->ts;
256 f->value.function.name
257 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
258 x->ts.kind);
259 }
260
261 void
262 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
263 {
264 f->ts = x->ts;
265 f->value.function.name
266 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
267 }
268
269 void
270 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
271 {
272 f->ts = x->ts;
273 f->value.function.name
274 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
275 x->ts.kind);
276 }
277
278 void
279 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
280 {
281 f->ts = x->ts;
282 f->value.function.name
283 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
284 x->ts.kind);
285 }
286
287
288 /* Resolve the BESYN and BESJN intrinsics. */
289
290 void
291 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
292 {
293 gfc_typespec ts;
294
295 f->ts = x->ts;
296 if (n->ts.kind != gfc_c_int_kind)
297 {
298 ts.type = BT_INTEGER;
299 ts.kind = gfc_c_int_kind;
300 gfc_convert_type (n, &ts, 2);
301 }
302 f->value.function.name = gfc_get_string ("<intrinsic>");
303 }
304
305
306 void
307 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
308 {
309 f->ts.type = BT_LOGICAL;
310 f->ts.kind = gfc_default_logical_kind;
311 f->value.function.name
312 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
313 }
314
315
316 void
317 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
318 {
319 f->ts.type = BT_INTEGER;
320 f->ts.kind = (kind == NULL)
321 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
322 f->value.function.name
323 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
324 gfc_type_letter (a->ts.type), a->ts.kind);
325 }
326
327
328 void
329 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
330 {
331 f->ts.type = BT_CHARACTER;
332 f->ts.kind = (kind == NULL)
333 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
334 f->value.function.name
335 = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
336 gfc_type_letter (a->ts.type), a->ts.kind);
337 }
338
339
340 void
341 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
342 {
343 f->ts.type = BT_INTEGER;
344 f->ts.kind = gfc_default_integer_kind;
345 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
346 }
347
348
349 void
350 gfc_resolve_chdir_sub (gfc_code *c)
351 {
352 const char *name;
353 int kind;
354
355 if (c->ext.actual->next->expr != NULL)
356 kind = c->ext.actual->next->expr->ts.kind;
357 else
358 kind = gfc_default_integer_kind;
359
360 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
361 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
362 }
363
364
365 void
366 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
367 gfc_expr *mode ATTRIBUTE_UNUSED)
368 {
369 f->ts.type = BT_INTEGER;
370 f->ts.kind = gfc_c_int_kind;
371 f->value.function.name = PREFIX ("chmod_func");
372 }
373
374
375 void
376 gfc_resolve_chmod_sub (gfc_code *c)
377 {
378 const char *name;
379 int kind;
380
381 if (c->ext.actual->next->next->expr != NULL)
382 kind = c->ext.actual->next->next->expr->ts.kind;
383 else
384 kind = gfc_default_integer_kind;
385
386 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
387 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
388 }
389
390
391 void
392 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
393 {
394 f->ts.type = BT_COMPLEX;
395 f->ts.kind = (kind == NULL)
396 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
397
398 if (y == NULL)
399 f->value.function.name
400 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
401 gfc_type_letter (x->ts.type), x->ts.kind);
402 else
403 f->value.function.name
404 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
405 gfc_type_letter (x->ts.type), x->ts.kind,
406 gfc_type_letter (y->ts.type), y->ts.kind);
407 }
408
409
410 void
411 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
412 {
413 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
414 }
415
416
417 void
418 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
419 {
420 int kind;
421
422 if (x->ts.type == BT_INTEGER)
423 {
424 if (y->ts.type == BT_INTEGER)
425 kind = gfc_default_real_kind;
426 else
427 kind = y->ts.kind;
428 }
429 else
430 {
431 if (y->ts.type == BT_REAL)
432 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
433 else
434 kind = x->ts.kind;
435 }
436
437 f->ts.type = BT_COMPLEX;
438 f->ts.kind = kind;
439 f->value.function.name
440 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
441 gfc_type_letter (x->ts.type), x->ts.kind,
442 gfc_type_letter (y->ts.type), y->ts.kind);
443 }
444
445
446 void
447 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
448 {
449 f->ts = x->ts;
450 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
451 }
452
453
454 void
455 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
456 {
457 f->ts = x->ts;
458 f->value.function.name
459 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
460 }
461
462
463 void
464 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
465 {
466 f->ts = x->ts;
467 f->value.function.name
468 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
469 }
470
471
472 void
473 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
474 {
475 f->ts.type = BT_INTEGER;
476 f->ts.kind = gfc_default_integer_kind;
477
478 if (dim != NULL)
479 {
480 f->rank = mask->rank - 1;
481 gfc_resolve_dim_arg (dim);
482 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
483 }
484
485 f->value.function.name
486 = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
487 gfc_type_letter (mask->ts.type), mask->ts.kind);
488 }
489
490
491 void
492 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
493 gfc_expr *dim)
494 {
495 int n;
496
497 f->ts = array->ts;
498 f->rank = array->rank;
499 f->shape = gfc_copy_shape (array->shape, array->rank);
500
501 if (shift->rank > 0)
502 n = 1;
503 else
504 n = 0;
505
506 /* Convert shift to at least gfc_default_integer_kind, so we don't need
507 kind=1 and kind=2 versions of the library functions. */
508 if (shift->ts.kind < gfc_default_integer_kind)
509 {
510 gfc_typespec ts;
511 ts.type = BT_INTEGER;
512 ts.kind = gfc_default_integer_kind;
513 gfc_convert_type_warn (shift, &ts, 2, 0);
514 }
515
516 if (dim != NULL)
517 {
518 gfc_resolve_dim_arg (dim);
519 /* Convert dim to shift's kind, so we don't need so many variations. */
520 if (dim->ts.kind != shift->ts.kind)
521 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
522 }
523 f->value.function.name
524 = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
525 array->ts.type == BT_CHARACTER ? "_char" : "");
526 }
527
528
529 void
530 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
531 {
532 gfc_typespec ts;
533
534 f->ts.type = BT_CHARACTER;
535 f->ts.kind = gfc_default_character_kind;
536
537 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
538 if (time->ts.kind != 8)
539 {
540 ts.type = BT_INTEGER;
541 ts.kind = 8;
542 ts.derived = NULL;
543 ts.cl = NULL;
544 gfc_convert_type (time, &ts, 2);
545 }
546
547 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
548 }
549
550
551 void
552 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
553 {
554 f->ts.type = BT_REAL;
555 f->ts.kind = gfc_default_double_kind;
556 f->value.function.name
557 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
558 }
559
560
561 void
562 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
563 {
564 f->ts.type = a->ts.type;
565 if (p != NULL)
566 f->ts.kind = gfc_kind_max (a,p);
567 else
568 f->ts.kind = a->ts.kind;
569
570 if (p != NULL && a->ts.kind != p->ts.kind)
571 {
572 if (a->ts.kind == gfc_kind_max (a,p))
573 gfc_convert_type (p, &a->ts, 2);
574 else
575 gfc_convert_type (a, &p->ts, 2);
576 }
577
578 f->value.function.name
579 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
580 }
581
582
583 void
584 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
585 {
586 gfc_expr temp;
587
588 temp.expr_type = EXPR_OP;
589 gfc_clear_ts (&temp.ts);
590 temp.value.op.operator = INTRINSIC_NONE;
591 temp.value.op.op1 = a;
592 temp.value.op.op2 = b;
593 gfc_type_convert_binary (&temp);
594 f->ts = temp.ts;
595 f->value.function.name
596 = gfc_get_string (PREFIX ("dot_product_%c%d"),
597 gfc_type_letter (f->ts.type), f->ts.kind);
598 }
599
600
601 void
602 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
603 gfc_expr *b ATTRIBUTE_UNUSED)
604 {
605 f->ts.kind = gfc_default_double_kind;
606 f->ts.type = BT_REAL;
607 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
608 }
609
610
611 void
612 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
613 gfc_expr *boundary, gfc_expr *dim)
614 {
615 int n;
616
617 f->ts = array->ts;
618 f->rank = array->rank;
619 f->shape = gfc_copy_shape (array->shape, array->rank);
620
621 n = 0;
622 if (shift->rank > 0)
623 n = n | 1;
624 if (boundary && boundary->rank > 0)
625 n = n | 2;
626
627 /* Convert shift to at least gfc_default_integer_kind, so we don't need
628 kind=1 and kind=2 versions of the library functions. */
629 if (shift->ts.kind < gfc_default_integer_kind)
630 {
631 gfc_typespec ts;
632 ts.type = BT_INTEGER;
633 ts.kind = gfc_default_integer_kind;
634 gfc_convert_type_warn (shift, &ts, 2, 0);
635 }
636
637 if (dim != NULL)
638 {
639 gfc_resolve_dim_arg (dim);
640 /* Convert dim to shift's kind, so we don't need so many variations. */
641 if (dim->ts.kind != shift->ts.kind)
642 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
643 }
644
645 f->value.function.name
646 = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
647 array->ts.type == BT_CHARACTER ? "_char" : "");
648 }
649
650
651 void
652 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
653 {
654 f->ts = x->ts;
655 f->value.function.name
656 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
657 }
658
659
660 void
661 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
662 {
663 f->ts.type = BT_INTEGER;
664 f->ts.kind = gfc_default_integer_kind;
665 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
666 }
667
668
669 void
670 gfc_resolve_fdate (gfc_expr *f)
671 {
672 f->ts.type = BT_CHARACTER;
673 f->ts.kind = gfc_default_character_kind;
674 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
675 }
676
677
678 void
679 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
680 {
681 f->ts.type = BT_INTEGER;
682 f->ts.kind = (kind == NULL)
683 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
684 f->value.function.name
685 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
686 gfc_type_letter (a->ts.type), a->ts.kind);
687 }
688
689
690 void
691 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
692 {
693 f->ts.type = BT_INTEGER;
694 f->ts.kind = gfc_default_integer_kind;
695 if (n->ts.kind != f->ts.kind)
696 gfc_convert_type (n, &f->ts, 2);
697 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
698 }
699
700
701 void
702 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
703 {
704 f->ts = x->ts;
705 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
706 }
707
708
709 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
710
711 void
712 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
713 {
714 f->ts = x->ts;
715 f->value.function.name = gfc_get_string ("<intrinsic>");
716 }
717
718
719 void
720 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
721 {
722 f->ts.type = BT_INTEGER;
723 f->ts.kind = 4;
724 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
725 }
726
727
728 void
729 gfc_resolve_getgid (gfc_expr *f)
730 {
731 f->ts.type = BT_INTEGER;
732 f->ts.kind = 4;
733 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
734 }
735
736
737 void
738 gfc_resolve_getpid (gfc_expr *f)
739 {
740 f->ts.type = BT_INTEGER;
741 f->ts.kind = 4;
742 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
743 }
744
745
746 void
747 gfc_resolve_getuid (gfc_expr *f)
748 {
749 f->ts.type = BT_INTEGER;
750 f->ts.kind = 4;
751 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
752 }
753
754
755 void
756 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
757 {
758 f->ts.type = BT_INTEGER;
759 f->ts.kind = 4;
760 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
761 }
762
763
764 void
765 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
766 {
767 /* If the kind of i and j are different, then g77 cross-promoted the
768 kinds to the largest value. The Fortran 95 standard requires the
769 kinds to match. */
770 if (i->ts.kind != j->ts.kind)
771 {
772 if (i->ts.kind == gfc_kind_max (i, j))
773 gfc_convert_type (j, &i->ts, 2);
774 else
775 gfc_convert_type (i, &j->ts, 2);
776 }
777
778 f->ts = i->ts;
779 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
780 }
781
782
783 void
784 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
785 {
786 f->ts = i->ts;
787 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
788 }
789
790
791 void
792 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
793 gfc_expr *len ATTRIBUTE_UNUSED)
794 {
795 f->ts = i->ts;
796 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
797 }
798
799
800 void
801 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
802 {
803 f->ts = i->ts;
804 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
805 }
806
807
808 void
809 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
810 {
811 f->ts.type = BT_INTEGER;
812 f->ts.kind = gfc_default_integer_kind;
813 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
814 }
815
816
817 void
818 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
819 {
820 gfc_resolve_nint (f, a, NULL);
821 }
822
823
824 void
825 gfc_resolve_ierrno (gfc_expr *f)
826 {
827 f->ts.type = BT_INTEGER;
828 f->ts.kind = gfc_default_integer_kind;
829 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
830 }
831
832
833 void
834 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
835 {
836 /* If the kind of i and j are different, then g77 cross-promoted the
837 kinds to the largest value. The Fortran 95 standard requires the
838 kinds to match. */
839 if (i->ts.kind != j->ts.kind)
840 {
841 if (i->ts.kind == gfc_kind_max (i, j))
842 gfc_convert_type (j, &i->ts, 2);
843 else
844 gfc_convert_type (i, &j->ts, 2);
845 }
846
847 f->ts = i->ts;
848 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
849 }
850
851
852 void
853 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
854 {
855 /* If the kind of i and j are different, then g77 cross-promoted the
856 kinds to the largest value. The Fortran 95 standard requires the
857 kinds to match. */
858 if (i->ts.kind != j->ts.kind)
859 {
860 if (i->ts.kind == gfc_kind_max (i, j))
861 gfc_convert_type (j, &i->ts, 2);
862 else
863 gfc_convert_type (i, &j->ts, 2);
864 }
865
866 f->ts = i->ts;
867 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
868 }
869
870
871 void
872 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
873 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
874 {
875 gfc_typespec ts;
876
877 f->ts.type = BT_INTEGER;
878 f->ts.kind = gfc_default_integer_kind;
879
880 if (back && back->ts.kind != gfc_default_integer_kind)
881 {
882 ts.type = BT_LOGICAL;
883 ts.kind = gfc_default_integer_kind;
884 ts.derived = NULL;
885 ts.cl = NULL;
886 gfc_convert_type (back, &ts, 2);
887 }
888
889 f->value.function.name
890 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
891 }
892
893
894 void
895 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
896 {
897 f->ts.type = BT_INTEGER;
898 f->ts.kind = (kind == NULL)
899 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
900 f->value.function.name
901 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
902 gfc_type_letter (a->ts.type), a->ts.kind);
903 }
904
905
906 void
907 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
908 {
909 f->ts.type = BT_INTEGER;
910 f->ts.kind = 2;
911 f->value.function.name
912 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
913 gfc_type_letter (a->ts.type), a->ts.kind);
914 }
915
916
917 void
918 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
919 {
920 f->ts.type = BT_INTEGER;
921 f->ts.kind = 8;
922 f->value.function.name
923 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
924 gfc_type_letter (a->ts.type), a->ts.kind);
925 }
926
927
928 void
929 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
930 {
931 f->ts.type = BT_INTEGER;
932 f->ts.kind = 4;
933 f->value.function.name
934 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
935 gfc_type_letter (a->ts.type), a->ts.kind);
936 }
937
938
939 void
940 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
941 {
942 gfc_typespec ts;
943
944 f->ts.type = BT_LOGICAL;
945 f->ts.kind = gfc_default_integer_kind;
946 if (u->ts.kind != gfc_c_int_kind)
947 {
948 ts.type = BT_INTEGER;
949 ts.kind = gfc_c_int_kind;
950 ts.derived = NULL;
951 ts.cl = NULL;
952 gfc_convert_type (u, &ts, 2);
953 }
954
955 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
956 }
957
958
959 void
960 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
961 {
962 f->ts = i->ts;
963 f->value.function.name
964 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
965 }
966
967
968 void
969 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
970 {
971 f->ts = i->ts;
972 f->value.function.name
973 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
974 }
975
976
977 void
978 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
979 {
980 f->ts = i->ts;
981 f->value.function.name
982 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
983 }
984
985
986 void
987 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
988 {
989 int s_kind;
990
991 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
992
993 f->ts = i->ts;
994 f->value.function.name
995 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
996 }
997
998
999 void
1000 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1001 gfc_expr *s ATTRIBUTE_UNUSED)
1002 {
1003 f->ts.type = BT_INTEGER;
1004 f->ts.kind = gfc_default_integer_kind;
1005 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1006 }
1007
1008
1009 void
1010 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1011 {
1012 static char lbound[] = "__lbound";
1013
1014 f->ts.type = BT_INTEGER;
1015 f->ts.kind = gfc_default_integer_kind;
1016
1017 if (dim == NULL)
1018 {
1019 f->rank = 1;
1020 f->shape = gfc_get_shape (1);
1021 mpz_init_set_ui (f->shape[0], array->rank);
1022 }
1023
1024 f->value.function.name = lbound;
1025 }
1026
1027
1028 void
1029 gfc_resolve_len (gfc_expr *f, gfc_expr *string)
1030 {
1031 f->ts.type = BT_INTEGER;
1032 f->ts.kind = gfc_default_integer_kind;
1033 f->value.function.name
1034 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1035 gfc_default_integer_kind);
1036 }
1037
1038
1039 void
1040 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
1041 {
1042 f->ts.type = BT_INTEGER;
1043 f->ts.kind = gfc_default_integer_kind;
1044 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1045 }
1046
1047
1048 void
1049 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1050 gfc_expr *p2 ATTRIBUTE_UNUSED)
1051 {
1052 f->ts.type = BT_INTEGER;
1053 f->ts.kind = gfc_default_integer_kind;
1054 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1055 }
1056
1057
1058 void
1059 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1060 {
1061 f->ts.type= BT_INTEGER;
1062 f->ts.kind = gfc_index_integer_kind;
1063 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1064 }
1065
1066
1067 void
1068 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1069 {
1070 f->ts = x->ts;
1071 f->value.function.name
1072 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1073 }
1074
1075
1076 void
1077 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1078 {
1079 f->ts = x->ts;
1080 f->value.function.name
1081 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1082 x->ts.kind);
1083 }
1084
1085
1086 void
1087 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1088 {
1089 f->ts.type = BT_LOGICAL;
1090 f->ts.kind = (kind == NULL)
1091 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1092 f->rank = a->rank;
1093
1094 f->value.function.name
1095 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1096 gfc_type_letter (a->ts.type), a->ts.kind);
1097 }
1098
1099
1100 void
1101 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1102 {
1103 if (size->ts.kind < gfc_index_integer_kind)
1104 {
1105 gfc_typespec ts;
1106
1107 ts.type = BT_INTEGER;
1108 ts.kind = gfc_index_integer_kind;
1109 gfc_convert_type_warn (size, &ts, 2, 0);
1110 }
1111
1112 f->ts.type = BT_INTEGER;
1113 f->ts.kind = gfc_index_integer_kind;
1114 f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1115 }
1116
1117
1118 void
1119 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1120 {
1121 gfc_expr temp;
1122
1123 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1124 {
1125 f->ts.type = BT_LOGICAL;
1126 f->ts.kind = gfc_default_logical_kind;
1127 }
1128 else
1129 {
1130 temp.expr_type = EXPR_OP;
1131 gfc_clear_ts (&temp.ts);
1132 temp.value.op.operator = INTRINSIC_NONE;
1133 temp.value.op.op1 = a;
1134 temp.value.op.op2 = b;
1135 gfc_type_convert_binary (&temp);
1136 f->ts = temp.ts;
1137 }
1138
1139 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1140
1141 f->value.function.name
1142 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1143 f->ts.kind);
1144 }
1145
1146
1147 static void
1148 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1149 {
1150 gfc_actual_arglist *a;
1151
1152 f->ts.type = args->expr->ts.type;
1153 f->ts.kind = args->expr->ts.kind;
1154 /* Find the largest type kind. */
1155 for (a = args->next; a; a = a->next)
1156 {
1157 if (a->expr->ts.kind > f->ts.kind)
1158 f->ts.kind = a->expr->ts.kind;
1159 }
1160
1161 /* Convert all parameters to the required kind. */
1162 for (a = args; a; a = a->next)
1163 {
1164 if (a->expr->ts.kind != f->ts.kind)
1165 gfc_convert_type (a->expr, &f->ts, 2);
1166 }
1167
1168 f->value.function.name
1169 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1170 }
1171
1172
1173 void
1174 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1175 {
1176 gfc_resolve_minmax ("__max_%c%d", f, args);
1177 }
1178
1179
1180 void
1181 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1182 gfc_expr *mask)
1183 {
1184 const char *name;
1185 int i, j, idim;
1186
1187 f->ts.type = BT_INTEGER;
1188 f->ts.kind = gfc_default_integer_kind;
1189
1190 if (dim == NULL)
1191 {
1192 f->rank = 1;
1193 f->shape = gfc_get_shape (1);
1194 mpz_init_set_si (f->shape[0], array->rank);
1195 }
1196 else
1197 {
1198 f->rank = array->rank - 1;
1199 gfc_resolve_dim_arg (dim);
1200 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1201 {
1202 idim = (int) mpz_get_si (dim->value.integer);
1203 f->shape = gfc_get_shape (f->rank);
1204 for (i = 0, j = 0; i < f->rank; i++, j++)
1205 {
1206 if (i == (idim - 1))
1207 j++;
1208 mpz_init_set (f->shape[i], array->shape[j]);
1209 }
1210 }
1211 }
1212
1213 if (mask)
1214 {
1215 if (mask->rank == 0)
1216 name = "smaxloc";
1217 else
1218 name = "mmaxloc";
1219
1220 /* The mask can be kind 4 or 8 for the array case. For the
1221 scalar case, coerce it to default kind unconditionally. */
1222 if ((mask->ts.kind < gfc_default_logical_kind)
1223 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1224 {
1225 gfc_typespec ts;
1226 ts.type = BT_LOGICAL;
1227 ts.kind = gfc_default_logical_kind;
1228 gfc_convert_type_warn (mask, &ts, 2, 0);
1229 }
1230 }
1231 else
1232 name = "maxloc";
1233
1234 /* If the rank of the function is nonzero, we are going to call
1235 a library function. Coerce the argument to one of the
1236 existing library functions for this case. */
1237
1238 if (f->rank != 0 && array->ts.type == BT_INTEGER
1239 && array->ts.kind < gfc_default_integer_kind)
1240 {
1241 gfc_typespec ts;
1242 ts.type = BT_INTEGER;
1243 ts.kind = gfc_default_integer_kind;
1244 gfc_convert_type_warn (array, &ts, 2, 0);
1245 }
1246
1247 f->value.function.name
1248 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1249 gfc_type_letter (array->ts.type), array->ts.kind);
1250 }
1251
1252
1253 void
1254 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1255 gfc_expr *mask)
1256 {
1257 const char *name;
1258 int i, j, idim;
1259
1260 f->ts = array->ts;
1261
1262 if (dim != NULL)
1263 {
1264 f->rank = array->rank - 1;
1265 gfc_resolve_dim_arg (dim);
1266
1267 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1268 {
1269 idim = (int) mpz_get_si (dim->value.integer);
1270 f->shape = gfc_get_shape (f->rank);
1271 for (i = 0, j = 0; i < f->rank; i++, j++)
1272 {
1273 if (i == (idim - 1))
1274 j++;
1275 mpz_init_set (f->shape[i], array->shape[j]);
1276 }
1277 }
1278 }
1279
1280 if (mask)
1281 {
1282 if (mask->rank == 0)
1283 name = "smaxval";
1284 else
1285 name = "mmaxval";
1286
1287 /* The mask can be kind 4 or 8 for the array case. For the
1288 scalar case, coerce it to default kind unconditionally. */
1289 if ((mask->ts.kind < gfc_default_logical_kind)
1290 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1291 {
1292 gfc_typespec ts;
1293 ts.type = BT_LOGICAL;
1294 ts.kind = gfc_default_logical_kind;
1295 gfc_convert_type_warn (mask, &ts, 2, 0);
1296 }
1297 }
1298 else
1299 name = "maxval";
1300
1301 f->value.function.name
1302 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1303 gfc_type_letter (array->ts.type), array->ts.kind);
1304 }
1305
1306
1307 void
1308 gfc_resolve_mclock (gfc_expr *f)
1309 {
1310 f->ts.type = BT_INTEGER;
1311 f->ts.kind = 4;
1312 f->value.function.name = PREFIX ("mclock");
1313 }
1314
1315
1316 void
1317 gfc_resolve_mclock8 (gfc_expr *f)
1318 {
1319 f->ts.type = BT_INTEGER;
1320 f->ts.kind = 8;
1321 f->value.function.name = PREFIX ("mclock8");
1322 }
1323
1324
1325 void
1326 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1327 gfc_expr *fsource ATTRIBUTE_UNUSED,
1328 gfc_expr *mask ATTRIBUTE_UNUSED)
1329 {
1330 if (tsource->ts.type == BT_CHARACTER)
1331 check_charlen_present (tsource);
1332
1333 f->ts = tsource->ts;
1334 f->value.function.name
1335 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1336 tsource->ts.kind);
1337 }
1338
1339
1340 void
1341 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1342 {
1343 gfc_resolve_minmax ("__min_%c%d", f, args);
1344 }
1345
1346
1347 void
1348 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1349 gfc_expr *mask)
1350 {
1351 const char *name;
1352 int i, j, idim;
1353
1354 f->ts.type = BT_INTEGER;
1355 f->ts.kind = gfc_default_integer_kind;
1356
1357 if (dim == NULL)
1358 {
1359 f->rank = 1;
1360 f->shape = gfc_get_shape (1);
1361 mpz_init_set_si (f->shape[0], array->rank);
1362 }
1363 else
1364 {
1365 f->rank = array->rank - 1;
1366 gfc_resolve_dim_arg (dim);
1367 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1368 {
1369 idim = (int) mpz_get_si (dim->value.integer);
1370 f->shape = gfc_get_shape (f->rank);
1371 for (i = 0, j = 0; i < f->rank; i++, j++)
1372 {
1373 if (i == (idim - 1))
1374 j++;
1375 mpz_init_set (f->shape[i], array->shape[j]);
1376 }
1377 }
1378 }
1379
1380 if (mask)
1381 {
1382 if (mask->rank == 0)
1383 name = "sminloc";
1384 else
1385 name = "mminloc";
1386
1387 /* The mask can be kind 4 or 8 for the array case. For the
1388 scalar case, coerce it to default kind unconditionally. */
1389 if ((mask->ts.kind < gfc_default_logical_kind)
1390 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1391 {
1392 gfc_typespec ts;
1393 ts.type = BT_LOGICAL;
1394 ts.kind = gfc_default_logical_kind;
1395 gfc_convert_type_warn (mask, &ts, 2, 0);
1396 }
1397 }
1398 else
1399 name = "minloc";
1400
1401 /* If the rank of the function is nonzero, we are going to call
1402 a library function. Coerce the argument to one of the
1403 existing library functions for this case. */
1404
1405 if (f->rank != 0 && array->ts.type == BT_INTEGER
1406 && array->ts.kind < gfc_default_integer_kind)
1407 {
1408 gfc_typespec ts;
1409 ts.type = BT_INTEGER;
1410 ts.kind = gfc_default_integer_kind;
1411 gfc_convert_type_warn (array, &ts, 2, 0);
1412 }
1413
1414 f->value.function.name
1415 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1416 gfc_type_letter (array->ts.type), array->ts.kind);
1417 }
1418
1419
1420 void
1421 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1422 gfc_expr *mask)
1423 {
1424 const char *name;
1425 int i, j, idim;
1426
1427 f->ts = array->ts;
1428
1429 if (dim != NULL)
1430 {
1431 f->rank = array->rank - 1;
1432 gfc_resolve_dim_arg (dim);
1433
1434 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1435 {
1436 idim = (int) mpz_get_si (dim->value.integer);
1437 f->shape = gfc_get_shape (f->rank);
1438 for (i = 0, j = 0; i < f->rank; i++, j++)
1439 {
1440 if (i == (idim - 1))
1441 j++;
1442 mpz_init_set (f->shape[i], array->shape[j]);
1443 }
1444 }
1445 }
1446
1447 if (mask)
1448 {
1449 if (mask->rank == 0)
1450 name = "sminval";
1451 else
1452 name = "mminval";
1453
1454 /* The mask can be kind 4 or 8 for the array case. For the
1455 scalar case, coerce it to default kind unconditionally. */
1456 if ((mask->ts.kind < gfc_default_logical_kind)
1457 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1458 {
1459 gfc_typespec ts;
1460 ts.type = BT_LOGICAL;
1461 ts.kind = gfc_default_logical_kind;
1462 gfc_convert_type_warn (mask, &ts, 2, 0);
1463 }
1464 }
1465 else
1466 name = "minval";
1467
1468 f->value.function.name
1469 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1470 gfc_type_letter (array->ts.type), array->ts.kind);
1471 }
1472
1473
1474 void
1475 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1476 {
1477 f->ts.type = a->ts.type;
1478 if (p != NULL)
1479 f->ts.kind = gfc_kind_max (a,p);
1480 else
1481 f->ts.kind = a->ts.kind;
1482
1483 if (p != NULL && a->ts.kind != p->ts.kind)
1484 {
1485 if (a->ts.kind == gfc_kind_max (a,p))
1486 gfc_convert_type (p, &a->ts, 2);
1487 else
1488 gfc_convert_type (a, &p->ts, 2);
1489 }
1490
1491 f->value.function.name
1492 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1493 }
1494
1495
1496 void
1497 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1498 {
1499 f->ts.type = a->ts.type;
1500 if (p != NULL)
1501 f->ts.kind = gfc_kind_max (a,p);
1502 else
1503 f->ts.kind = a->ts.kind;
1504
1505 if (p != NULL && a->ts.kind != p->ts.kind)
1506 {
1507 if (a->ts.kind == gfc_kind_max (a,p))
1508 gfc_convert_type (p, &a->ts, 2);
1509 else
1510 gfc_convert_type (a, &p->ts, 2);
1511 }
1512
1513 f->value.function.name
1514 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1515 f->ts.kind);
1516 }
1517
1518 void
1519 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
1520 {
1521 f->ts = a->ts;
1522 f->value.function.name
1523 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1524 a->ts.kind);
1525 }
1526
1527 void
1528 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1529 {
1530 f->ts.type = BT_INTEGER;
1531 f->ts.kind = (kind == NULL)
1532 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1533 f->value.function.name
1534 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1535 }
1536
1537
1538 void
1539 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1540 {
1541 f->ts = i->ts;
1542 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1543 }
1544
1545
1546 void
1547 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1548 {
1549 f->ts.type = i->ts.type;
1550 f->ts.kind = gfc_kind_max (i, j);
1551
1552 if (i->ts.kind != j->ts.kind)
1553 {
1554 if (i->ts.kind == gfc_kind_max (i, j))
1555 gfc_convert_type (j, &i->ts, 2);
1556 else
1557 gfc_convert_type (i, &j->ts, 2);
1558 }
1559
1560 f->value.function.name
1561 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1562 }
1563
1564
1565 void
1566 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1567 gfc_expr *vector ATTRIBUTE_UNUSED)
1568 {
1569 f->ts = array->ts;
1570 f->rank = 1;
1571
1572 if (mask->rank != 0)
1573 f->value.function.name = (array->ts.type == BT_CHARACTER
1574 ? PREFIX ("pack_char") : PREFIX ("pack"));
1575 else
1576 {
1577 /* We convert mask to default logical only in the scalar case.
1578 In the array case we can simply read the array as if it were
1579 of type default logical. */
1580 if (mask->ts.kind != gfc_default_logical_kind)
1581 {
1582 gfc_typespec ts;
1583
1584 ts.type = BT_LOGICAL;
1585 ts.kind = gfc_default_logical_kind;
1586 gfc_convert_type (mask, &ts, 2);
1587 }
1588
1589 f->value.function.name = (array->ts.type == BT_CHARACTER
1590 ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
1591 }
1592 }
1593
1594
1595 void
1596 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1597 gfc_expr *mask)
1598 {
1599 const char *name;
1600
1601 f->ts = array->ts;
1602
1603 if (dim != NULL)
1604 {
1605 f->rank = array->rank - 1;
1606 gfc_resolve_dim_arg (dim);
1607 }
1608
1609 if (mask)
1610 {
1611 if (mask->rank == 0)
1612 name = "sproduct";
1613 else
1614 name = "mproduct";
1615
1616 /* The mask can be kind 4 or 8 for the array case. For the
1617 scalar case, coerce it to default kind unconditionally. */
1618 if ((mask->ts.kind < gfc_default_logical_kind)
1619 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1620 {
1621 gfc_typespec ts;
1622 ts.type = BT_LOGICAL;
1623 ts.kind = gfc_default_logical_kind;
1624 gfc_convert_type_warn (mask, &ts, 2, 0);
1625 }
1626 }
1627 else
1628 name = "product";
1629
1630 f->value.function.name
1631 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1632 gfc_type_letter (array->ts.type), array->ts.kind);
1633 }
1634
1635
1636 void
1637 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1638 {
1639 f->ts.type = BT_REAL;
1640
1641 if (kind != NULL)
1642 f->ts.kind = mpz_get_si (kind->value.integer);
1643 else
1644 f->ts.kind = (a->ts.type == BT_COMPLEX)
1645 ? a->ts.kind : gfc_default_real_kind;
1646
1647 f->value.function.name
1648 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1649 gfc_type_letter (a->ts.type), a->ts.kind);
1650 }
1651
1652
1653 void
1654 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1655 {
1656 f->ts.type = BT_REAL;
1657 f->ts.kind = a->ts.kind;
1658 f->value.function.name
1659 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1660 gfc_type_letter (a->ts.type), a->ts.kind);
1661 }
1662
1663
1664 void
1665 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1666 gfc_expr *p2 ATTRIBUTE_UNUSED)
1667 {
1668 f->ts.type = BT_INTEGER;
1669 f->ts.kind = gfc_default_integer_kind;
1670 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1671 }
1672
1673
1674 void
1675 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1676 gfc_expr *ncopies ATTRIBUTE_UNUSED)
1677 {
1678 f->ts.type = BT_CHARACTER;
1679 f->ts.kind = string->ts.kind;
1680 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1681 }
1682
1683
1684 void
1685 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1686 gfc_expr *pad ATTRIBUTE_UNUSED,
1687 gfc_expr *order ATTRIBUTE_UNUSED)
1688 {
1689 mpz_t rank;
1690 int kind;
1691 int i;
1692
1693 f->ts = source->ts;
1694
1695 gfc_array_size (shape, &rank);
1696 f->rank = mpz_get_si (rank);
1697 mpz_clear (rank);
1698 switch (source->ts.type)
1699 {
1700 case BT_COMPLEX:
1701 case BT_REAL:
1702 case BT_INTEGER:
1703 case BT_LOGICAL:
1704 kind = source->ts.kind;
1705 break;
1706
1707 default:
1708 kind = 0;
1709 break;
1710 }
1711
1712 switch (kind)
1713 {
1714 case 4:
1715 case 8:
1716 case 10:
1717 case 16:
1718 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1719 f->value.function.name
1720 = gfc_get_string (PREFIX ("reshape_%c%d"),
1721 gfc_type_letter (source->ts.type),
1722 source->ts.kind);
1723 else
1724 f->value.function.name
1725 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1726
1727 break;
1728
1729 default:
1730 f->value.function.name = (source->ts.type == BT_CHARACTER
1731 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1732 break;
1733 }
1734
1735 /* TODO: Make this work with a constant ORDER parameter. */
1736 if (shape->expr_type == EXPR_ARRAY
1737 && gfc_is_constant_expr (shape)
1738 && order == NULL)
1739 {
1740 gfc_constructor *c;
1741 f->shape = gfc_get_shape (f->rank);
1742 c = shape->value.constructor;
1743 for (i = 0; i < f->rank; i++)
1744 {
1745 mpz_init_set (f->shape[i], c->expr->value.integer);
1746 c = c->next;
1747 }
1748 }
1749
1750 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1751 so many runtime variations. */
1752 if (shape->ts.kind != gfc_index_integer_kind)
1753 {
1754 gfc_typespec ts = shape->ts;
1755 ts.kind = gfc_index_integer_kind;
1756 gfc_convert_type_warn (shape, &ts, 2, 0);
1757 }
1758 if (order && order->ts.kind != gfc_index_integer_kind)
1759 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1760 }
1761
1762
1763 void
1764 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1765 {
1766 int k;
1767 gfc_actual_arglist *prec;
1768
1769 f->ts = x->ts;
1770 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1771
1772 /* Create a hidden argument to the library routines for rrspacing. This
1773 hidden argument is the precision of x. */
1774 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1775 prec = gfc_get_actual_arglist ();
1776 prec->name = "p";
1777 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
1778 f->value.function.actual->next = prec;
1779 }
1780
1781
1782 void
1783 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
1784 {
1785 f->ts = x->ts;
1786
1787 /* The implementation calls scalbn which takes an int as the
1788 second argument. */
1789 if (i->ts.kind != gfc_c_int_kind)
1790 {
1791 gfc_typespec ts;
1792 ts.type = BT_INTEGER;
1793 ts.kind = gfc_default_integer_kind;
1794 gfc_convert_type_warn (i, &ts, 2, 0);
1795 }
1796
1797 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1798 }
1799
1800
1801 void
1802 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
1803 gfc_expr *set ATTRIBUTE_UNUSED,
1804 gfc_expr *back ATTRIBUTE_UNUSED)
1805 {
1806 f->ts.type = BT_INTEGER;
1807 f->ts.kind = gfc_default_integer_kind;
1808 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1809 }
1810
1811
1812 void
1813 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
1814 {
1815 t1->ts = t0->ts;
1816 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
1817 }
1818
1819
1820 void
1821 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
1822 {
1823 f->ts = x->ts;
1824
1825 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1826 convert type so we don't have to implement all possible
1827 permutations. */
1828 if (i->ts.kind != 4)
1829 {
1830 gfc_typespec ts;
1831 ts.type = BT_INTEGER;
1832 ts.kind = gfc_default_integer_kind;
1833 gfc_convert_type_warn (i, &ts, 2, 0);
1834 }
1835
1836 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1837 }
1838
1839
1840 void
1841 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
1842 {
1843 f->ts.type = BT_INTEGER;
1844 f->ts.kind = gfc_default_integer_kind;
1845 f->rank = 1;
1846 f->shape = gfc_get_shape (1);
1847 mpz_init_set_ui (f->shape[0], array->rank);
1848 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
1849 }
1850
1851
1852 void
1853 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
1854 {
1855 f->ts = a->ts;
1856 f->value.function.name
1857 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1858 }
1859
1860
1861 void
1862 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
1863 {
1864 f->ts.type = BT_INTEGER;
1865 f->ts.kind = gfc_c_int_kind;
1866
1867 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1868 if (handler->ts.type == BT_INTEGER)
1869 {
1870 if (handler->ts.kind != gfc_c_int_kind)
1871 gfc_convert_type (handler, &f->ts, 2);
1872 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
1873 }
1874 else
1875 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
1876
1877 if (number->ts.kind != gfc_c_int_kind)
1878 gfc_convert_type (number, &f->ts, 2);
1879 }
1880
1881
1882 void
1883 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
1884 {
1885 f->ts = x->ts;
1886 f->value.function.name
1887 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1888 }
1889
1890
1891 void
1892 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
1893 {
1894 f->ts = x->ts;
1895 f->value.function.name
1896 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1897 }
1898
1899
1900 void
1901 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
1902 {
1903 int k;
1904 gfc_actual_arglist *prec, *tiny, *emin_1;
1905
1906 f->ts = x->ts;
1907 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1908
1909 /* Create hidden arguments to the library routine for spacing. These
1910 hidden arguments are tiny(x), min_exponent - 1, and the precision
1911 of x. */
1912
1913 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1914
1915 tiny = gfc_get_actual_arglist ();
1916 tiny->name = "tiny";
1917 tiny->expr = gfc_get_expr ();
1918 tiny->expr->expr_type = EXPR_CONSTANT;
1919 tiny->expr->where = gfc_current_locus;
1920 tiny->expr->ts.type = x->ts.type;
1921 tiny->expr->ts.kind = x->ts.kind;
1922 mpfr_init (tiny->expr->value.real);
1923 mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
1924
1925 emin_1 = gfc_get_actual_arglist ();
1926 emin_1->name = "emin";
1927 emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
1928 emin_1->next = tiny;
1929
1930 prec = gfc_get_actual_arglist ();
1931 prec->name = "prec";
1932 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
1933 prec->next = emin_1;
1934
1935 f->value.function.actual->next = prec;
1936 }
1937
1938
1939 void
1940 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
1941 gfc_expr *ncopies)
1942 {
1943 if (source->ts.type == BT_CHARACTER)
1944 check_charlen_present (source);
1945
1946 f->ts = source->ts;
1947 f->rank = source->rank + 1;
1948 if (source->rank == 0)
1949 f->value.function.name = (source->ts.type == BT_CHARACTER
1950 ? PREFIX ("spread_char_scalar")
1951 : PREFIX ("spread_scalar"));
1952 else
1953 f->value.function.name = (source->ts.type == BT_CHARACTER
1954 ? PREFIX ("spread_char")
1955 : PREFIX ("spread"));
1956
1957 if (dim && gfc_is_constant_expr (dim)
1958 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
1959 {
1960 int i, idim;
1961 idim = mpz_get_ui (dim->value.integer);
1962 f->shape = gfc_get_shape (f->rank);
1963 for (i = 0; i < (idim - 1); i++)
1964 mpz_init_set (f->shape[i], source->shape[i]);
1965
1966 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
1967
1968 for (i = idim; i < f->rank ; i++)
1969 mpz_init_set (f->shape[i], source->shape[i-1]);
1970 }
1971
1972
1973 gfc_resolve_dim_arg (dim);
1974 gfc_resolve_index (ncopies, 1);
1975 }
1976
1977
1978 void
1979 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
1980 {
1981 f->ts = x->ts;
1982 f->value.function.name
1983 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1984 }
1985
1986
1987 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1988
1989 void
1990 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
1991 gfc_expr *a ATTRIBUTE_UNUSED)
1992 {
1993 f->ts.type = BT_INTEGER;
1994 f->ts.kind = gfc_default_integer_kind;
1995 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
1996 }
1997
1998
1999 void
2000 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2001 gfc_expr *a ATTRIBUTE_UNUSED)
2002 {
2003 f->ts.type = BT_INTEGER;
2004 f->ts.kind = gfc_default_integer_kind;
2005 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2006 }
2007
2008
2009 void
2010 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2011 {
2012 f->ts.type = BT_INTEGER;
2013 f->ts.kind = gfc_default_integer_kind;
2014 if (n->ts.kind != f->ts.kind)
2015 gfc_convert_type (n, &f->ts, 2);
2016
2017 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2018 }
2019
2020
2021 void
2022 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2023 {
2024 gfc_typespec ts;
2025
2026 f->ts.type = BT_INTEGER;
2027 f->ts.kind = gfc_c_int_kind;
2028 if (u->ts.kind != gfc_c_int_kind)
2029 {
2030 ts.type = BT_INTEGER;
2031 ts.kind = gfc_c_int_kind;
2032 ts.derived = NULL;
2033 ts.cl = NULL;
2034 gfc_convert_type (u, &ts, 2);
2035 }
2036
2037 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2038 }
2039
2040
2041 void
2042 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2043 {
2044 f->ts.type = BT_INTEGER;
2045 f->ts.kind = gfc_c_int_kind;
2046 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2047 }
2048
2049
2050 void
2051 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2052 {
2053 gfc_typespec ts;
2054
2055 f->ts.type = BT_INTEGER;
2056 f->ts.kind = gfc_c_int_kind;
2057 if (u->ts.kind != gfc_c_int_kind)
2058 {
2059 ts.type = BT_INTEGER;
2060 ts.kind = gfc_c_int_kind;
2061 ts.derived = NULL;
2062 ts.cl = NULL;
2063 gfc_convert_type (u, &ts, 2);
2064 }
2065
2066 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2067 }
2068
2069
2070 void
2071 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2072 {
2073 f->ts.type = BT_INTEGER;
2074 f->ts.kind = gfc_c_int_kind;
2075 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2076 }
2077
2078
2079 void
2080 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2081 {
2082 gfc_typespec ts;
2083
2084 f->ts.type = BT_INTEGER;
2085 f->ts.kind = gfc_index_integer_kind;
2086 if (u->ts.kind != gfc_c_int_kind)
2087 {
2088 ts.type = BT_INTEGER;
2089 ts.kind = gfc_c_int_kind;
2090 ts.derived = NULL;
2091 ts.cl = NULL;
2092 gfc_convert_type (u, &ts, 2);
2093 }
2094
2095 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2096 }
2097
2098
2099 void
2100 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2101 {
2102 const char *name;
2103
2104 f->ts = array->ts;
2105
2106 if (mask)
2107 {
2108 if (mask->rank == 0)
2109 name = "ssum";
2110 else
2111 name = "msum";
2112
2113 /* The mask can be kind 4 or 8 for the array case. For the
2114 scalar case, coerce it to default kind unconditionally. */
2115 if ((mask->ts.kind < gfc_default_logical_kind)
2116 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
2117 {
2118 gfc_typespec ts;
2119 ts.type = BT_LOGICAL;
2120 ts.kind = gfc_default_logical_kind;
2121 gfc_convert_type_warn (mask, &ts, 2, 0);
2122 }
2123 }
2124 else
2125 name = "sum";
2126
2127 if (dim != NULL)
2128 {
2129 f->rank = array->rank - 1;
2130 gfc_resolve_dim_arg (dim);
2131 }
2132
2133 f->value.function.name
2134 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2135 gfc_type_letter (array->ts.type), array->ts.kind);
2136 }
2137
2138
2139 void
2140 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2141 gfc_expr *p2 ATTRIBUTE_UNUSED)
2142 {
2143 f->ts.type = BT_INTEGER;
2144 f->ts.kind = gfc_default_integer_kind;
2145 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2146 }
2147
2148
2149 /* Resolve the g77 compatibility function SYSTEM. */
2150
2151 void
2152 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2153 {
2154 f->ts.type = BT_INTEGER;
2155 f->ts.kind = 4;
2156 f->value.function.name = gfc_get_string (PREFIX ("system"));
2157 }
2158
2159
2160 void
2161 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2162 {
2163 f->ts = x->ts;
2164 f->value.function.name
2165 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2166 }
2167
2168
2169 void
2170 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2171 {
2172 f->ts = x->ts;
2173 f->value.function.name
2174 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2175 }
2176
2177
2178 void
2179 gfc_resolve_time (gfc_expr *f)
2180 {
2181 f->ts.type = BT_INTEGER;
2182 f->ts.kind = 4;
2183 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2184 }
2185
2186
2187 void
2188 gfc_resolve_time8 (gfc_expr *f)
2189 {
2190 f->ts.type = BT_INTEGER;
2191 f->ts.kind = 8;
2192 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2193 }
2194
2195
2196 void
2197 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2198 gfc_expr *mold, gfc_expr *size)
2199 {
2200 /* TODO: Make this do something meaningful. */
2201 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2202
2203 f->ts = mold->ts;
2204
2205 if (size == NULL && mold->rank == 0)
2206 {
2207 f->rank = 0;
2208 f->value.function.name = transfer0;
2209 }
2210 else
2211 {
2212 f->rank = 1;
2213 f->value.function.name = transfer1;
2214 if (size && gfc_is_constant_expr (size))
2215 {
2216 f->shape = gfc_get_shape (1);
2217 mpz_init_set (f->shape[0], size->value.integer);
2218 }
2219 }
2220 }
2221
2222
2223 void
2224 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2225 {
2226 f->ts = matrix->ts;
2227 f->rank = 2;
2228 if (matrix->shape)
2229 {
2230 f->shape = gfc_get_shape (2);
2231 mpz_init_set (f->shape[0], matrix->shape[1]);
2232 mpz_init_set (f->shape[1], matrix->shape[0]);
2233 }
2234
2235 switch (matrix->ts.kind)
2236 {
2237 case 4:
2238 case 8:
2239 case 10:
2240 case 16:
2241 switch (matrix->ts.type)
2242 {
2243 case BT_REAL:
2244 case BT_COMPLEX:
2245 f->value.function.name
2246 = gfc_get_string (PREFIX ("transpose_%c%d"),
2247 gfc_type_letter (matrix->ts.type),
2248 matrix->ts.kind);
2249 break;
2250
2251 case BT_INTEGER:
2252 case BT_LOGICAL:
2253 /* Use the integer routines for real and logical cases. This
2254 assumes they all have the same alignment requirements. */
2255 f->value.function.name
2256 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2257 break;
2258
2259 default:
2260 f->value.function.name = PREFIX ("transpose");
2261 break;
2262 }
2263 break;
2264
2265 default:
2266 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2267 ? PREFIX ("transpose_char")
2268 : PREFIX ("transpose"));
2269 break;
2270 }
2271 }
2272
2273
2274 void
2275 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2276 {
2277 f->ts.type = BT_CHARACTER;
2278 f->ts.kind = string->ts.kind;
2279 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2280 }
2281
2282
2283 void
2284 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2285 {
2286 static char ubound[] = "__ubound";
2287
2288 f->ts.type = BT_INTEGER;
2289 f->ts.kind = gfc_default_integer_kind;
2290
2291 if (dim == NULL)
2292 {
2293 f->rank = 1;
2294 f->shape = gfc_get_shape (1);
2295 mpz_init_set_ui (f->shape[0], array->rank);
2296 }
2297
2298 f->value.function.name = ubound;
2299 }
2300
2301
2302 /* Resolve the g77 compatibility function UMASK. */
2303
2304 void
2305 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2306 {
2307 f->ts.type = BT_INTEGER;
2308 f->ts.kind = n->ts.kind;
2309 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2310 }
2311
2312
2313 /* Resolve the g77 compatibility function UNLINK. */
2314
2315 void
2316 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2317 {
2318 f->ts.type = BT_INTEGER;
2319 f->ts.kind = 4;
2320 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2321 }
2322
2323
2324 void
2325 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2326 {
2327 gfc_typespec ts;
2328
2329 f->ts.type = BT_CHARACTER;
2330 f->ts.kind = gfc_default_character_kind;
2331
2332 if (unit->ts.kind != gfc_c_int_kind)
2333 {
2334 ts.type = BT_INTEGER;
2335 ts.kind = gfc_c_int_kind;
2336 ts.derived = NULL;
2337 ts.cl = NULL;
2338 gfc_convert_type (unit, &ts, 2);
2339 }
2340
2341 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2342 }
2343
2344
2345 void
2346 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2347 gfc_expr *field ATTRIBUTE_UNUSED)
2348 {
2349 f->ts = vector->ts;
2350 f->rank = mask->rank;
2351
2352 f->value.function.name
2353 = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
2354 vector->ts.type == BT_CHARACTER ? "_char" : "");
2355 }
2356
2357
2358 void
2359 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2360 gfc_expr *set ATTRIBUTE_UNUSED,
2361 gfc_expr *back ATTRIBUTE_UNUSED)
2362 {
2363 f->ts.type = BT_INTEGER;
2364 f->ts.kind = gfc_default_integer_kind;
2365 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2366 }
2367
2368
2369 void
2370 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2371 {
2372 f->ts.type = i->ts.type;
2373 f->ts.kind = gfc_kind_max (i, j);
2374
2375 if (i->ts.kind != j->ts.kind)
2376 {
2377 if (i->ts.kind == gfc_kind_max (i, j))
2378 gfc_convert_type (j, &i->ts, 2);
2379 else
2380 gfc_convert_type (i, &j->ts, 2);
2381 }
2382
2383 f->value.function.name
2384 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2385 }
2386
2387
2388 /* Intrinsic subroutine resolution. */
2389
2390 void
2391 gfc_resolve_alarm_sub (gfc_code *c)
2392 {
2393 const char *name;
2394 gfc_expr *seconds, *handler, *status;
2395 gfc_typespec ts;
2396
2397 seconds = c->ext.actual->expr;
2398 handler = c->ext.actual->next->expr;
2399 status = c->ext.actual->next->next->expr;
2400 ts.type = BT_INTEGER;
2401 ts.kind = gfc_c_int_kind;
2402
2403 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2404 if (handler->ts.type == BT_INTEGER)
2405 {
2406 if (handler->ts.kind != gfc_c_int_kind)
2407 gfc_convert_type (handler, &ts, 2);
2408 name = gfc_get_string (PREFIX ("alarm_sub_int"));
2409 }
2410 else
2411 name = gfc_get_string (PREFIX ("alarm_sub"));
2412
2413 if (seconds->ts.kind != gfc_c_int_kind)
2414 gfc_convert_type (seconds, &ts, 2);
2415 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2416 gfc_convert_type (status, &ts, 2);
2417
2418 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2419 }
2420
2421 void
2422 gfc_resolve_cpu_time (gfc_code *c)
2423 {
2424 const char *name;
2425 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2426 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2427 }
2428
2429
2430 void
2431 gfc_resolve_mvbits (gfc_code *c)
2432 {
2433 const char *name;
2434 int kind;
2435 kind = c->ext.actual->expr->ts.kind;
2436 name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
2437 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2438 }
2439
2440
2441 void
2442 gfc_resolve_random_number (gfc_code *c)
2443 {
2444 const char *name;
2445 int kind;
2446
2447 kind = c->ext.actual->expr->ts.kind;
2448 if (c->ext.actual->expr->rank == 0)
2449 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2450 else
2451 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2452
2453 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2454 }
2455
2456
2457 void
2458 gfc_resolve_rename_sub (gfc_code *c)
2459 {
2460 const char *name;
2461 int kind;
2462
2463 if (c->ext.actual->next->next->expr != NULL)
2464 kind = c->ext.actual->next->next->expr->ts.kind;
2465 else
2466 kind = gfc_default_integer_kind;
2467
2468 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2469 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2470 }
2471
2472
2473 void
2474 gfc_resolve_kill_sub (gfc_code *c)
2475 {
2476 const char *name;
2477 int kind;
2478
2479 if (c->ext.actual->next->next->expr != NULL)
2480 kind = c->ext.actual->next->next->expr->ts.kind;
2481 else
2482 kind = gfc_default_integer_kind;
2483
2484 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2485 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2486 }
2487
2488
2489 void
2490 gfc_resolve_link_sub (gfc_code *c)
2491 {
2492 const char *name;
2493 int kind;
2494
2495 if (c->ext.actual->next->next->expr != NULL)
2496 kind = c->ext.actual->next->next->expr->ts.kind;
2497 else
2498 kind = gfc_default_integer_kind;
2499
2500 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2501 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2502 }
2503
2504
2505 void
2506 gfc_resolve_symlnk_sub (gfc_code *c)
2507 {
2508 const char *name;
2509 int kind;
2510
2511 if (c->ext.actual->next->next->expr != NULL)
2512 kind = c->ext.actual->next->next->expr->ts.kind;
2513 else
2514 kind = gfc_default_integer_kind;
2515
2516 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2517 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2518 }
2519
2520
2521 /* G77 compatibility subroutines etime() and dtime(). */
2522
2523 void
2524 gfc_resolve_etime_sub (gfc_code *c)
2525 {
2526 const char *name;
2527 name = gfc_get_string (PREFIX ("etime_sub"));
2528 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2529 }
2530
2531
2532 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2533
2534 void
2535 gfc_resolve_itime (gfc_code *c)
2536 {
2537 c->resolved_sym
2538 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2539 gfc_default_integer_kind));
2540 }
2541
2542 void
2543 gfc_resolve_idate (gfc_code *c)
2544 {
2545 c->resolved_sym
2546 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2547 gfc_default_integer_kind));
2548 }
2549
2550 void
2551 gfc_resolve_ltime (gfc_code *c)
2552 {
2553 c->resolved_sym
2554 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2555 gfc_default_integer_kind));
2556 }
2557
2558 void
2559 gfc_resolve_gmtime (gfc_code *c)
2560 {
2561 c->resolved_sym
2562 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2563 gfc_default_integer_kind));
2564 }
2565
2566
2567 /* G77 compatibility subroutine second(). */
2568
2569 void
2570 gfc_resolve_second_sub (gfc_code *c)
2571 {
2572 const char *name;
2573 name = gfc_get_string (PREFIX ("second_sub"));
2574 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2575 }
2576
2577
2578 void
2579 gfc_resolve_sleep_sub (gfc_code *c)
2580 {
2581 const char *name;
2582 int kind;
2583
2584 if (c->ext.actual->expr != NULL)
2585 kind = c->ext.actual->expr->ts.kind;
2586 else
2587 kind = gfc_default_integer_kind;
2588
2589 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2590 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2591 }
2592
2593
2594 /* G77 compatibility function srand(). */
2595
2596 void
2597 gfc_resolve_srand (gfc_code *c)
2598 {
2599 const char *name;
2600 name = gfc_get_string (PREFIX ("srand"));
2601 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2602 }
2603
2604
2605 /* Resolve the getarg intrinsic subroutine. */
2606
2607 void
2608 gfc_resolve_getarg (gfc_code *c)
2609 {
2610 const char *name;
2611 int kind;
2612 kind = gfc_default_integer_kind;
2613 name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
2614 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2615 }
2616
2617
2618 /* Resolve the getcwd intrinsic subroutine. */
2619
2620 void
2621 gfc_resolve_getcwd_sub (gfc_code *c)
2622 {
2623 const char *name;
2624 int kind;
2625
2626 if (c->ext.actual->next->expr != NULL)
2627 kind = c->ext.actual->next->expr->ts.kind;
2628 else
2629 kind = gfc_default_integer_kind;
2630
2631 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2632 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2633 }
2634
2635
2636 /* Resolve the get_command intrinsic subroutine. */
2637
2638 void
2639 gfc_resolve_get_command (gfc_code *c)
2640 {
2641 const char *name;
2642 int kind;
2643 kind = gfc_default_integer_kind;
2644 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2645 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2646 }
2647
2648
2649 /* Resolve the get_command_argument intrinsic subroutine. */
2650
2651 void
2652 gfc_resolve_get_command_argument (gfc_code *c)
2653 {
2654 const char *name;
2655 int kind;
2656 kind = gfc_default_integer_kind;
2657 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2658 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2659 }
2660
2661
2662 /* Resolve the get_environment_variable intrinsic subroutine. */
2663
2664 void
2665 gfc_resolve_get_environment_variable (gfc_code *code)
2666 {
2667 const char *name;
2668 int kind;
2669 kind = gfc_default_integer_kind;
2670 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2671 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2672 }
2673
2674
2675 void
2676 gfc_resolve_signal_sub (gfc_code *c)
2677 {
2678 const char *name;
2679 gfc_expr *number, *handler, *status;
2680 gfc_typespec ts;
2681
2682 number = c->ext.actual->expr;
2683 handler = c->ext.actual->next->expr;
2684 status = c->ext.actual->next->next->expr;
2685 ts.type = BT_INTEGER;
2686 ts.kind = gfc_c_int_kind;
2687
2688 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2689 if (handler->ts.type == BT_INTEGER)
2690 {
2691 if (handler->ts.kind != gfc_c_int_kind)
2692 gfc_convert_type (handler, &ts, 2);
2693 name = gfc_get_string (PREFIX ("signal_sub_int"));
2694 }
2695 else
2696 name = gfc_get_string (PREFIX ("signal_sub"));
2697
2698 if (number->ts.kind != gfc_c_int_kind)
2699 gfc_convert_type (number, &ts, 2);
2700 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2701 gfc_convert_type (status, &ts, 2);
2702
2703 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2704 }
2705
2706
2707 /* Resolve the SYSTEM intrinsic subroutine. */
2708
2709 void
2710 gfc_resolve_system_sub (gfc_code *c)
2711 {
2712 const char *name;
2713 name = gfc_get_string (PREFIX ("system_sub"));
2714 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2715 }
2716
2717
2718 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2719
2720 void
2721 gfc_resolve_system_clock (gfc_code *c)
2722 {
2723 const char *name;
2724 int kind;
2725
2726 if (c->ext.actual->expr != NULL)
2727 kind = c->ext.actual->expr->ts.kind;
2728 else if (c->ext.actual->next->expr != NULL)
2729 kind = c->ext.actual->next->expr->ts.kind;
2730 else if (c->ext.actual->next->next->expr != NULL)
2731 kind = c->ext.actual->next->next->expr->ts.kind;
2732 else
2733 kind = gfc_default_integer_kind;
2734
2735 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
2736 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2737 }
2738
2739
2740 /* Resolve the EXIT intrinsic subroutine. */
2741
2742 void
2743 gfc_resolve_exit (gfc_code *c)
2744 {
2745 const char *name;
2746 int kind;
2747
2748 if (c->ext.actual->expr != NULL)
2749 kind = c->ext.actual->expr->ts.kind;
2750 else
2751 kind = gfc_default_integer_kind;
2752
2753 name = gfc_get_string (PREFIX ("exit_i%d"), kind);
2754 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2755 }
2756
2757
2758 /* Resolve the FLUSH intrinsic subroutine. */
2759
2760 void
2761 gfc_resolve_flush (gfc_code *c)
2762 {
2763 const char *name;
2764 gfc_typespec ts;
2765 gfc_expr *n;
2766
2767 ts.type = BT_INTEGER;
2768 ts.kind = gfc_default_integer_kind;
2769 n = c->ext.actual->expr;
2770 if (n != NULL && n->ts.kind != ts.kind)
2771 gfc_convert_type (n, &ts, 2);
2772
2773 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
2774 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2775 }
2776
2777
2778 void
2779 gfc_resolve_free (gfc_code *c)
2780 {
2781 gfc_typespec ts;
2782 gfc_expr *n;
2783
2784 ts.type = BT_INTEGER;
2785 ts.kind = gfc_index_integer_kind;
2786 n = c->ext.actual->expr;
2787 if (n->ts.kind != ts.kind)
2788 gfc_convert_type (n, &ts, 2);
2789
2790 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
2791 }
2792
2793
2794 void
2795 gfc_resolve_ctime_sub (gfc_code *c)
2796 {
2797 gfc_typespec ts;
2798
2799 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2800 if (c->ext.actual->expr->ts.kind != 8)
2801 {
2802 ts.type = BT_INTEGER;
2803 ts.kind = 8;
2804 ts.derived = NULL;
2805 ts.cl = NULL;
2806 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2807 }
2808
2809 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
2810 }
2811
2812
2813 void
2814 gfc_resolve_fdate_sub (gfc_code *c)
2815 {
2816 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2817 }
2818
2819
2820 void
2821 gfc_resolve_gerror (gfc_code *c)
2822 {
2823 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2824 }
2825
2826
2827 void
2828 gfc_resolve_getlog (gfc_code *c)
2829 {
2830 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2831 }
2832
2833
2834 void
2835 gfc_resolve_hostnm_sub (gfc_code *c)
2836 {
2837 const char *name;
2838 int kind;
2839
2840 if (c->ext.actual->next->expr != NULL)
2841 kind = c->ext.actual->next->expr->ts.kind;
2842 else
2843 kind = gfc_default_integer_kind;
2844
2845 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
2846 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2847 }
2848
2849
2850 void
2851 gfc_resolve_perror (gfc_code *c)
2852 {
2853 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2854 }
2855
2856 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2857
2858 void
2859 gfc_resolve_stat_sub (gfc_code *c)
2860 {
2861 const char *name;
2862 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
2863 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2864 }
2865
2866
2867 void
2868 gfc_resolve_lstat_sub (gfc_code *c)
2869 {
2870 const char *name;
2871 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
2872 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2873 }
2874
2875
2876 void
2877 gfc_resolve_fstat_sub (gfc_code *c)
2878 {
2879 const char *name;
2880 gfc_expr *u;
2881 gfc_typespec *ts;
2882
2883 u = c->ext.actual->expr;
2884 ts = &c->ext.actual->next->expr->ts;
2885 if (u->ts.kind != ts->kind)
2886 gfc_convert_type (u, ts, 2);
2887 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
2888 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2889 }
2890
2891
2892 void
2893 gfc_resolve_fgetc_sub (gfc_code *c)
2894 {
2895 const char *name;
2896 gfc_typespec ts;
2897 gfc_expr *u, *st;
2898
2899 u = c->ext.actual->expr;
2900 st = c->ext.actual->next->next->expr;
2901
2902 if (u->ts.kind != gfc_c_int_kind)
2903 {
2904 ts.type = BT_INTEGER;
2905 ts.kind = gfc_c_int_kind;
2906 ts.derived = NULL;
2907 ts.cl = NULL;
2908 gfc_convert_type (u, &ts, 2);
2909 }
2910
2911 if (st != NULL)
2912 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
2913 else
2914 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
2915
2916 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2917 }
2918
2919
2920 void
2921 gfc_resolve_fget_sub (gfc_code *c)
2922 {
2923 const char *name;
2924 gfc_expr *st;
2925
2926 st = c->ext.actual->next->expr;
2927 if (st != NULL)
2928 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
2929 else
2930 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
2931
2932 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2933 }
2934
2935
2936 void
2937 gfc_resolve_fputc_sub (gfc_code *c)
2938 {
2939 const char *name;
2940 gfc_typespec ts;
2941 gfc_expr *u, *st;
2942
2943 u = c->ext.actual->expr;
2944 st = c->ext.actual->next->next->expr;
2945
2946 if (u->ts.kind != gfc_c_int_kind)
2947 {
2948 ts.type = BT_INTEGER;
2949 ts.kind = gfc_c_int_kind;
2950 ts.derived = NULL;
2951 ts.cl = NULL;
2952 gfc_convert_type (u, &ts, 2);
2953 }
2954
2955 if (st != NULL)
2956 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
2957 else
2958 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
2959
2960 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2961 }
2962
2963
2964 void
2965 gfc_resolve_fput_sub (gfc_code *c)
2966 {
2967 const char *name;
2968 gfc_expr *st;
2969
2970 st = c->ext.actual->next->expr;
2971 if (st != NULL)
2972 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
2973 else
2974 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
2975
2976 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2977 }
2978
2979
2980 void
2981 gfc_resolve_ftell_sub (gfc_code *c)
2982 {
2983 const char *name;
2984 gfc_expr *unit;
2985 gfc_expr *offset;
2986 gfc_typespec ts;
2987
2988 unit = c->ext.actual->expr;
2989 offset = c->ext.actual->next->expr;
2990
2991 if (unit->ts.kind != gfc_c_int_kind)
2992 {
2993 ts.type = BT_INTEGER;
2994 ts.kind = gfc_c_int_kind;
2995 ts.derived = NULL;
2996 ts.cl = NULL;
2997 gfc_convert_type (unit, &ts, 2);
2998 }
2999
3000 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3001 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3002 }
3003
3004
3005 void
3006 gfc_resolve_ttynam_sub (gfc_code *c)
3007 {
3008 gfc_typespec ts;
3009
3010 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3011 {
3012 ts.type = BT_INTEGER;
3013 ts.kind = gfc_c_int_kind;
3014 ts.derived = NULL;
3015 ts.cl = NULL;
3016 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3017 }
3018
3019 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3020 }
3021
3022
3023 /* Resolve the UMASK intrinsic subroutine. */
3024
3025 void
3026 gfc_resolve_umask_sub (gfc_code *c)
3027 {
3028 const char *name;
3029 int kind;
3030
3031 if (c->ext.actual->next->expr != NULL)
3032 kind = c->ext.actual->next->expr->ts.kind;
3033 else
3034 kind = gfc_default_integer_kind;
3035
3036 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3037 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3038 }
3039
3040 /* Resolve the UNLINK intrinsic subroutine. */
3041
3042 void
3043 gfc_resolve_unlink_sub (gfc_code *c)
3044 {
3045 const char *name;
3046 int kind;
3047
3048 if (c->ext.actual->next->expr != NULL)
3049 kind = c->ext.actual->next->expr->ts.kind;
3050 else
3051 kind = gfc_default_integer_kind;
3052
3053 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3054 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3055 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org