?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / fortran / iresolve.c
blobc702294fc82049f97171684d562e146839921633
1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
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
39 /* Given printf-like arguments, return a stable version of the result string.
40
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
45
46 const char *
47 gfc_get_string (const char *format, ...)
48 {
49 char temp_name[128];
50 va_list ap;
51 tree ident;
52
53 va_start (ap, format);
54 vsnprintf (temp_name, sizeof(temp_name), format, ap);
55 va_end (ap);
56 temp_name[sizeof(temp_name)-1] = 0;
57
58 ident = get_identifier (temp_name);
59 return IDENTIFIER_POINTER (ident);
60 }
61
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
64 static void
65 check_charlen_present (gfc_expr *source)
66 {
67 if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
68 {
69 source->ts.cl = gfc_get_charlen ();
70 source->ts.cl->next = gfc_current_ns->cl_list;
71 gfc_current_ns->cl_list = source->ts.cl;
72 source->ts.cl->length = gfc_int_expr (source->value.character.length);
73 source->rank = 0;
74 }
75 }
76
77 /********************** Resolution functions **********************/
78
79
80 void
81 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
82 {
83 f->ts = a->ts;
84 if (f->ts.type == BT_COMPLEX)
85 f->ts.type = BT_REAL;
86
87 f->value.function.name =
88 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
89 }
90
91
92 void
93 gfc_resolve_access (gfc_expr * f, gfc_expr * name ATTRIBUTE_UNUSED,
94 gfc_expr * mode ATTRIBUTE_UNUSED)
95 {
96 f->ts.type = BT_INTEGER;
97 f->ts.kind = gfc_c_int_kind;
98 f->value.function.name = PREFIX("access_func");
99 }
100
101
102 void
103 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
104 {
105 f->ts = x->ts;
106 f->value.function.name =
107 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
108 }
109
110
111 void
112 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
113 {
114 f->ts = x->ts;
115 f->value.function.name =
116 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), 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), x->ts.kind);
127 }
128
129
130 void
131 gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
132 {
133 f->ts.type = i->ts.type;
134 f->ts.kind = gfc_kind_max (i,j);
135
136 if (i->ts.kind != j->ts.kind)
137 {
138 if (i->ts.kind == gfc_kind_max (i,j))
139 gfc_convert_type(j, &i->ts, 2);
140 else
141 gfc_convert_type(i, &j->ts, 2);
142 }
143
144 f->value.function.name = gfc_get_string ("__and_%c%d",
145 gfc_type_letter (i->ts.type),
146 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), a->ts.kind);
215 }
216
217
218 void
219 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
220 {
221 gfc_resolve_anint (f, a, NULL);
222 }
223
224
225 void
226 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
227 {
228 f->ts = mask->ts;
229
230 if (dim != NULL)
231 {
232 gfc_resolve_dim_arg (dim);
233 f->rank = mask->rank - 1;
234 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
235 }
236
237 f->value.function.name =
238 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
239 mask->ts.kind);
240 }
241
242
243 void
244 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
245 {
246 f->ts = x->ts;
247 f->value.function.name =
248 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
249 }
250
251 void
252 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
253 {
254 f->ts = x->ts;
255 f->value.function.name =
256 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
257 }
258
259 void
260 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
261 {
262 f->ts = x->ts;
263 f->value.function.name =
264 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
265 }
266
267 void
268 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
269 {
270 f->ts = x->ts;
271 f->value.function.name =
272 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
273 }
274
275 void
276 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
277 gfc_expr * y ATTRIBUTE_UNUSED)
278 {
279 f->ts = x->ts;
280 f->value.function.name =
281 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
282 }
283
284
285 /* Resolve the BESYN and BESJN intrinsics. */
286
287 void
288 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
289 {
290 gfc_typespec ts;
291
292 f->ts = x->ts;
293 if (n->ts.kind != gfc_c_int_kind)
294 {
295 ts.type = BT_INTEGER;
296 ts.kind = gfc_c_int_kind;
297 gfc_convert_type (n, &ts, 2);
298 }
299 f->value.function.name = gfc_get_string ("<intrinsic>");
300 }
301
302
303 void
304 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
305 {
306 f->ts.type = BT_LOGICAL;
307 f->ts.kind = gfc_default_logical_kind;
308
309 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
310 pos->ts.kind);
311 }
312
313
314 void
315 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
316 {
317 f->ts.type = BT_INTEGER;
318 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
319 : mpz_get_si (kind->value.integer);
320
321 f->value.function.name =
322 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
323 gfc_type_letter (a->ts.type), a->ts.kind);
324 }
325
326
327 void
328 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
329 {
330 f->ts.type = BT_CHARACTER;
331 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
332 : mpz_get_si (kind->value.integer);
333
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) ? gfc_default_real_kind
396 : 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 void
410 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
411 {
412 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
413 }
414
415 void
416 gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
417 {
418 int kind;
419
420 if (x->ts.type == BT_INTEGER)
421 {
422 if (y->ts.type == BT_INTEGER)
423 kind = gfc_default_real_kind;
424 else
425 kind = y->ts.kind;
426 }
427 else
428 {
429 if (y->ts.type == BT_REAL)
430 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
431 else
432 kind = x->ts.kind;
433 }
434
435 f->ts.type = BT_COMPLEX;
436 f->ts.kind = kind;
437
438 f->value.function.name =
439 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
440 gfc_type_letter (x->ts.type), x->ts.kind,
441 gfc_type_letter (y->ts.type), y->ts.kind);
442 }
443
444
445 void
446 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
447 {
448 f->ts = x->ts;
449 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
450 }
451
452
453 void
454 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
455 {
456 f->ts = x->ts;
457 f->value.function.name =
458 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
459 }
460
461
462 void
463 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
464 {
465 f->ts = x->ts;
466 f->value.function.name =
467 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
468 }
469
470
471 void
472 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
473 {
474 f->ts.type = BT_INTEGER;
475 f->ts.kind = gfc_default_integer_kind;
476
477 if (dim != NULL)
478 {
479 f->rank = mask->rank - 1;
480 gfc_resolve_dim_arg (dim);
481 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
482 }
483
484 f->value.function.name =
485 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
486 gfc_type_letter (mask->ts.type), mask->ts.kind);
487 }
488
489
490 void
491 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
492 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
596 f->value.function.name =
597 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
598 f->ts.kind);
599 }
600
601
602 void
603 gfc_resolve_dprod (gfc_expr * f,
604 gfc_expr * a ATTRIBUTE_UNUSED,
605 gfc_expr * b ATTRIBUTE_UNUSED)
606 {
607 f->ts.kind = gfc_default_double_kind;
608 f->ts.type = BT_REAL;
609
610 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
611 }
612
613
614 void
615 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
616 gfc_expr * shift,
617 gfc_expr * boundary,
618 gfc_expr * dim)
619 {
620 int n;
621
622 f->ts = array->ts;
623 f->rank = array->rank;
624 f->shape = gfc_copy_shape (array->shape, array->rank);
625
626 n = 0;
627 if (shift->rank > 0)
628 n = n | 1;
629 if (boundary && boundary->rank > 0)
630 n = n | 2;
631
632 /* Convert shift to at least gfc_default_integer_kind, so we don't need
633 kind=1 and kind=2 versions of the library functions. */
634 if (shift->ts.kind < gfc_default_integer_kind)
635 {
636 gfc_typespec ts;
637 ts.type = BT_INTEGER;
638 ts.kind = gfc_default_integer_kind;
639 gfc_convert_type_warn (shift, &ts, 2, 0);
640 }
641
642 if (dim != NULL)
643 {
644 gfc_resolve_dim_arg (dim);
645 /* Convert dim to shift's kind, so we don't need so many variations. */
646 if (dim->ts.kind != shift->ts.kind)
647 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
648 }
649
650 f->value.function.name =
651 gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
652 array->ts.type == BT_CHARACTER ? "_char" : "");
653 }
654
655
656 void
657 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
658 {
659 f->ts = x->ts;
660 f->value.function.name =
661 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
662 }
663
664
665 void
666 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
667 {
668 f->ts.type = BT_INTEGER;
669 f->ts.kind = gfc_default_integer_kind;
670
671 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
672 }
673
674
675 void
676 gfc_resolve_fdate (gfc_expr * f)
677 {
678 f->ts.type = BT_CHARACTER;
679 f->ts.kind = gfc_default_character_kind;
680 f->value.function.name = gfc_get_string (PREFIX("fdate"));
681 }
682
683
684 void
685 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
686 {
687 f->ts.type = BT_INTEGER;
688 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
689 : mpz_get_si (kind->value.integer);
690
691 f->value.function.name =
692 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
693 gfc_type_letter (a->ts.type), a->ts.kind);
694 }
695
696
697 void
698 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
699 {
700 f->ts.type = BT_INTEGER;
701 f->ts.kind = gfc_default_integer_kind;
702 if (n->ts.kind != f->ts.kind)
703 gfc_convert_type (n, &f->ts, 2);
704 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
705 }
706
707
708 void
709 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
710 {
711 f->ts = x->ts;
712 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
713 }
714
715
716 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
717
718 void
719 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
720 {
721 f->ts = x->ts;
722 f->value.function.name = gfc_get_string ("<intrinsic>");
723 }
724
725
726 void
727 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
728 {
729 f->ts.type = BT_INTEGER;
730 f->ts.kind = 4;
731 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
732 }
733
734
735 void
736 gfc_resolve_getgid (gfc_expr * f)
737 {
738 f->ts.type = BT_INTEGER;
739 f->ts.kind = 4;
740 f->value.function.name = gfc_get_string (PREFIX("getgid"));
741 }
742
743
744 void
745 gfc_resolve_getpid (gfc_expr * f)
746 {
747 f->ts.type = BT_INTEGER;
748 f->ts.kind = 4;
749 f->value.function.name = gfc_get_string (PREFIX("getpid"));
750 }
751
752
753 void
754 gfc_resolve_getuid (gfc_expr * f)
755 {
756 f->ts.type = BT_INTEGER;
757 f->ts.kind = 4;
758 f->value.function.name = gfc_get_string (PREFIX("getuid"));
759 }
760
761 void
762 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
763 {
764 f->ts.type = BT_INTEGER;
765 f->ts.kind = 4;
766 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
767 }
768
769 void
770 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
771 {
772 /* If the kind of i and j are different, then g77 cross-promoted the
773 kinds to the largest value. The Fortran 95 standard requires the
774 kinds to match. */
775 if (i->ts.kind != j->ts.kind)
776 {
777 if (i->ts.kind == gfc_kind_max (i,j))
778 gfc_convert_type(j, &i->ts, 2);
779 else
780 gfc_convert_type(i, &j->ts, 2);
781 }
782
783 f->ts = i->ts;
784 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
785 }
786
787
788 void
789 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
790 {
791 f->ts = i->ts;
792 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
793 }
794
795
796 void
797 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
798 gfc_expr * pos ATTRIBUTE_UNUSED,
799 gfc_expr * len ATTRIBUTE_UNUSED)
800 {
801 f->ts = i->ts;
802 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
803 }
804
805
806 void
807 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
808 gfc_expr * pos ATTRIBUTE_UNUSED)
809 {
810 f->ts = i->ts;
811 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
812 }
813
814
815 void
816 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
817 {
818 f->ts.type = BT_INTEGER;
819 f->ts.kind = gfc_default_integer_kind;
820
821 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
822 }
823
824
825 void
826 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
827 {
828 gfc_resolve_nint (f, a, NULL);
829 }
830
831
832 void
833 gfc_resolve_ierrno (gfc_expr * f)
834 {
835 f->ts.type = BT_INTEGER;
836 f->ts.kind = gfc_default_integer_kind;
837 f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
838 }
839
840
841 void
842 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
843 {
844 /* If the kind of i and j are different, then g77 cross-promoted the
845 kinds to the largest value. The Fortran 95 standard requires the
846 kinds to match. */
847 if (i->ts.kind != j->ts.kind)
848 {
849 if (i->ts.kind == gfc_kind_max (i,j))
850 gfc_convert_type(j, &i->ts, 2);
851 else
852 gfc_convert_type(i, &j->ts, 2);
853 }
854
855 f->ts = i->ts;
856 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
857 }
858
859
860 void
861 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
862 {
863 /* If the kind of i and j are different, then g77 cross-promoted the
864 kinds to the largest value. The Fortran 95 standard requires the
865 kinds to match. */
866 if (i->ts.kind != j->ts.kind)
867 {
868 if (i->ts.kind == gfc_kind_max (i,j))
869 gfc_convert_type(j, &i->ts, 2);
870 else
871 gfc_convert_type(i, &j->ts, 2);
872 }
873
874 f->ts = i->ts;
875 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
876 }
877
878
879 void
880 gfc_resolve_index_func (gfc_expr * f, gfc_expr * str,
881 ATTRIBUTE_UNUSED gfc_expr * sub_str, gfc_expr * back)
882 {
883 gfc_typespec ts;
884
885 f->ts.type = BT_INTEGER;
886 f->ts.kind = gfc_default_integer_kind;
887
888 if (back && back->ts.kind != gfc_default_integer_kind)
889 {
890 ts.type = BT_LOGICAL;
891 ts.kind = gfc_default_integer_kind;
892 ts.derived = NULL;
893 ts.cl = NULL;
894 gfc_convert_type (back, &ts, 2);
895 }
896
897 f->value.function.name =
898 gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
899 }
900
901
902 void
903 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
904 {
905 f->ts.type = BT_INTEGER;
906 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
907 : mpz_get_si (kind->value.integer);
908
909 f->value.function.name =
910 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
911 a->ts.kind);
912 }
913
914
915 void
916 gfc_resolve_int2 (gfc_expr * f, gfc_expr * a)
917 {
918 f->ts.type = BT_INTEGER;
919 f->ts.kind = 2;
920
921 f->value.function.name =
922 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
923 a->ts.kind);
924 }
925
926
927 void
928 gfc_resolve_int8 (gfc_expr * f, gfc_expr * a)
929 {
930 f->ts.type = BT_INTEGER;
931 f->ts.kind = 8;
932
933 f->value.function.name =
934 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
935 a->ts.kind);
936 }
937
938
939 void
940 gfc_resolve_long (gfc_expr * f, gfc_expr * a)
941 {
942 f->ts.type = BT_INTEGER;
943 f->ts.kind = 4;
944
945 f->value.function.name =
946 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
947 a->ts.kind);
948 }
949
950
951 void
952 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
953 {
954 gfc_typespec ts;
955
956 f->ts.type = BT_LOGICAL;
957 f->ts.kind = gfc_default_integer_kind;
958 if (u->ts.kind != gfc_c_int_kind)
959 {
960 ts.type = BT_INTEGER;
961 ts.kind = gfc_c_int_kind;
962 ts.derived = NULL;
963 ts.cl = NULL;
964 gfc_convert_type (u, &ts, 2);
965 }
966
967 f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
968 }
969
970
971 void
972 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
973 {
974 f->ts = i->ts;
975 f->value.function.name =
976 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
977 }
978
979
980 void
981 gfc_resolve_rshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
982 {
983 f->ts = i->ts;
984 f->value.function.name =
985 gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
986 }
987
988
989 void
990 gfc_resolve_lshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
991 {
992 f->ts = i->ts;
993 f->value.function.name =
994 gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
995 }
996
997
998 void
999 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
1000 gfc_expr * size)
1001 {
1002 int s_kind;
1003
1004 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
1005
1006 f->ts = i->ts;
1007 f->value.function.name =
1008 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1009 }
1010
1011
1012 void
1013 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
1014 ATTRIBUTE_UNUSED gfc_expr * s)
1015 {
1016 f->ts.type = BT_INTEGER;
1017 f->ts.kind = gfc_default_integer_kind;
1018
1019 f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
1020 }
1021
1022
1023 void
1024 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
1025 gfc_expr * dim)
1026 {
1027 static char lbound[] = "__lbound";
1028
1029 f->ts.type = BT_INTEGER;
1030 f->ts.kind = gfc_default_integer_kind;
1031
1032 if (dim == NULL)
1033 {
1034 f->rank = 1;
1035 f->shape = gfc_get_shape (1);
1036 mpz_init_set_ui (f->shape[0], array->rank);
1037 }
1038
1039 f->value.function.name = lbound;
1040 }
1041
1042
1043 void
1044 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
1045 {
1046 f->ts.type = BT_INTEGER;
1047 f->ts.kind = gfc_default_integer_kind;
1048 f->value.function.name = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1049 gfc_default_integer_kind);
1050 }
1051
1052
1053 void
1054 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
1055 {
1056 f->ts.type = BT_INTEGER;
1057 f->ts.kind = gfc_default_integer_kind;
1058 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1059 }
1060
1061
1062 void
1063 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1064 gfc_expr * p2 ATTRIBUTE_UNUSED)
1065 {
1066 f->ts.type = BT_INTEGER;
1067 f->ts.kind = gfc_default_integer_kind;
1068 f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
1069 }
1070
1071
1072 void
1073 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1074 {
1075 f->ts.type= BT_INTEGER;
1076 f->ts.kind = gfc_index_integer_kind;
1077 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1078 }
1079
1080
1081 void
1082 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
1083 {
1084 f->ts = x->ts;
1085 f->value.function.name =
1086 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1087 }
1088
1089
1090 void
1091 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
1092 {
1093 f->ts = x->ts;
1094 f->value.function.name =
1095 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1096 }
1097
1098
1099 void
1100 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1101 {
1102 f->ts.type = BT_LOGICAL;
1103 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
1104 : mpz_get_si (kind->value.integer);
1105 f->rank = a->rank;
1106
1107 f->value.function.name =
1108 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1109 gfc_type_letter (a->ts.type), a->ts.kind);
1110 }
1111
1112
1113 void
1114 gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
1115 {
1116 if (size->ts.kind < gfc_index_integer_kind)
1117 {
1118 gfc_typespec ts;
1119
1120 ts.type = BT_INTEGER;
1121 ts.kind = gfc_index_integer_kind;
1122 gfc_convert_type_warn (size, &ts, 2, 0);
1123 }
1124
1125 f->ts.type = BT_INTEGER;
1126 f->ts.kind = gfc_index_integer_kind;
1127 f->value.function.name = gfc_get_string (PREFIX("malloc"));
1128 }
1129
1130
1131 void
1132 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
1133 {
1134 gfc_expr temp;
1135
1136 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1137 {
1138 f->ts.type = BT_LOGICAL;
1139 f->ts.kind = gfc_default_logical_kind;
1140 }
1141 else
1142 {
1143 temp.expr_type = EXPR_OP;
1144 gfc_clear_ts (&temp.ts);
1145 temp.value.op.operator = INTRINSIC_NONE;
1146 temp.value.op.op1 = a;
1147 temp.value.op.op2 = b;
1148 gfc_type_convert_binary (&temp);
1149 f->ts = temp.ts;
1150 }
1151
1152 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1153
1154 f->value.function.name =
1155 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
1156 f->ts.kind);
1157 }
1158
1159
1160 static void
1161 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
1162 {
1163 gfc_actual_arglist *a;
1164
1165 f->ts.type = args->expr->ts.type;
1166 f->ts.kind = args->expr->ts.kind;
1167 /* Find the largest type kind. */
1168 for (a = args->next; a; a = a->next)
1169 {
1170 if (a->expr->ts.kind > f->ts.kind)
1171 f->ts.kind = a->expr->ts.kind;
1172 }
1173
1174 /* Convert all parameters to the required kind. */
1175 for (a = args; a; a = a->next)
1176 {
1177 if (a->expr->ts.kind != f->ts.kind)
1178 gfc_convert_type (a->expr, &f->ts, 2);
1179 }
1180
1181 f->value.function.name =
1182 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1183 }
1184
1185
1186 void
1187 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
1188 {
1189 gfc_resolve_minmax ("__max_%c%d", f, args);
1190 }
1191
1192
1193 void
1194 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1195 gfc_expr * mask)
1196 {
1197 const char *name;
1198 int i, j, idim;
1199
1200 f->ts.type = BT_INTEGER;
1201 f->ts.kind = gfc_default_integer_kind;
1202
1203 if (dim == NULL)
1204 {
1205 f->rank = 1;
1206 f->shape = gfc_get_shape (1);
1207 mpz_init_set_si (f->shape[0], array->rank);
1208 }
1209 else
1210 {
1211 f->rank = array->rank - 1;
1212 gfc_resolve_dim_arg (dim);
1213 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1214 {
1215 idim = (int) mpz_get_si (dim->value.integer);
1216 f->shape = gfc_get_shape (f->rank);
1217 for (i = 0, j = 0; i < f->rank; i++, j++)
1218 {
1219 if (i == (idim - 1))
1220 j++;
1221 mpz_init_set (f->shape[i], array->shape[j]);
1222 }
1223 }
1224 }
1225
1226 if (mask)
1227 {
1228 if (mask->rank == 0)
1229 name = "smaxloc";
1230 else
1231 name = "mmaxloc";
1232
1233 /* The mask can be kind 4 or 8 for the array case. For the
1234 scalar case, coerce it to default kind unconditionally. */
1235 if ((mask->ts.kind < gfc_default_logical_kind)
1236 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1237 {
1238 gfc_typespec ts;
1239 ts.type = BT_LOGICAL;
1240 ts.kind = gfc_default_logical_kind;
1241 gfc_convert_type_warn (mask, &ts, 2, 0);
1242 }
1243 }
1244 else
1245 name = "maxloc";
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 f->value.function.name =
1402 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1403 gfc_type_letter (array->ts.type), array->ts.kind);
1404 }
1405
1406
1407 void
1408 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1409 gfc_expr * mask)
1410 {
1411 const char *name;
1412 int i, j, idim;
1413
1414 f->ts = array->ts;
1415
1416 if (dim != NULL)
1417 {
1418 f->rank = array->rank - 1;
1419 gfc_resolve_dim_arg (dim);
1420
1421 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1422 {
1423 idim = (int) mpz_get_si (dim->value.integer);
1424 f->shape = gfc_get_shape (f->rank);
1425 for (i = 0, j = 0; i < f->rank; i++, j++)
1426 {
1427 if (i == (idim - 1))
1428 j++;
1429 mpz_init_set (f->shape[i], array->shape[j]);
1430 }
1431 }
1432 }
1433
1434 if (mask)
1435 {
1436 if (mask->rank == 0)
1437 name = "sminval";
1438 else
1439 name = "mminval";
1440
1441 /* The mask can be kind 4 or 8 for the array case. For the
1442 scalar case, coerce it to default kind unconditionally. */
1443 if ((mask->ts.kind < gfc_default_logical_kind)
1444 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1445 {
1446 gfc_typespec ts;
1447 ts.type = BT_LOGICAL;
1448 ts.kind = gfc_default_logical_kind;
1449 gfc_convert_type_warn (mask, &ts, 2, 0);
1450 }
1451 }
1452 else
1453 name = "minval";
1454
1455 f->value.function.name =
1456 gfc_get_string (PREFIX("%s_%c%d"), name,
1457 gfc_type_letter (array->ts.type), array->ts.kind);
1458 }
1459
1460
1461 void
1462 gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1463 {
1464 f->ts.type = a->ts.type;
1465 if (p != NULL)
1466 f->ts.kind = gfc_kind_max (a,p);
1467 else
1468 f->ts.kind = a->ts.kind;
1469
1470 if (p != NULL && a->ts.kind != p->ts.kind)
1471 {
1472 if (a->ts.kind == gfc_kind_max (a,p))
1473 gfc_convert_type(p, &a->ts, 2);
1474 else
1475 gfc_convert_type(a, &p->ts, 2);
1476 }
1477
1478 f->value.function.name =
1479 gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1480 }
1481
1482
1483 void
1484 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1485 {
1486 f->ts.type = a->ts.type;
1487 if (p != NULL)
1488 f->ts.kind = gfc_kind_max (a,p);
1489 else
1490 f->ts.kind = a->ts.kind;
1491
1492 if (p != NULL && a->ts.kind != p->ts.kind)
1493 {
1494 if (a->ts.kind == gfc_kind_max (a,p))
1495 gfc_convert_type(p, &a->ts, 2);
1496 else
1497 gfc_convert_type(a, &p->ts, 2);
1498 }
1499
1500 f->value.function.name =
1501 gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1502 f->ts.kind);
1503 }
1504
1505 void
1506 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1507 {
1508 f->ts = a->ts;
1509 f->value.function.name =
1510 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1511 a->ts.kind);
1512 }
1513
1514 void
1515 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1516 {
1517 f->ts.type = BT_INTEGER;
1518 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1519 : mpz_get_si (kind->value.integer);
1520
1521 f->value.function.name =
1522 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1523 }
1524
1525
1526 void
1527 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1528 {
1529 f->ts = i->ts;
1530 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1531 }
1532
1533
1534 void
1535 gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1536 {
1537 f->ts.type = i->ts.type;
1538 f->ts.kind = gfc_kind_max (i,j);
1539
1540 if (i->ts.kind != j->ts.kind)
1541 {
1542 if (i->ts.kind == gfc_kind_max (i,j))
1543 gfc_convert_type(j, &i->ts, 2);
1544 else
1545 gfc_convert_type(i, &j->ts, 2);
1546 }
1547
1548 f->value.function.name = gfc_get_string ("__or_%c%d",
1549 gfc_type_letter (i->ts.type),
1550 f->ts.kind);
1551 }
1552
1553
1554 void
1555 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1556 gfc_expr * vector ATTRIBUTE_UNUSED)
1557 {
1558 f->ts = array->ts;
1559 f->rank = 1;
1560
1561 if (mask->rank != 0)
1562 f->value.function.name = (array->ts.type == BT_CHARACTER
1563 ? PREFIX("pack_char")
1564 : PREFIX("pack"));
1565 else
1566 {
1567 /* We convert mask to default logical only in the scalar case.
1568 In the array case we can simply read the array as if it were
1569 of type default logical. */
1570 if (mask->ts.kind != gfc_default_logical_kind)
1571 {
1572 gfc_typespec ts;
1573
1574 ts.type = BT_LOGICAL;
1575 ts.kind = gfc_default_logical_kind;
1576 gfc_convert_type (mask, &ts, 2);
1577 }
1578
1579 f->value.function.name = (array->ts.type == BT_CHARACTER
1580 ? PREFIX("pack_s_char")
1581 : PREFIX("pack_s"));
1582 }
1583 }
1584
1585
1586 void
1587 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1588 gfc_expr * mask)
1589 {
1590 const char *name;
1591
1592 f->ts = array->ts;
1593
1594 if (dim != NULL)
1595 {
1596 f->rank = array->rank - 1;
1597 gfc_resolve_dim_arg (dim);
1598 }
1599
1600 if (mask)
1601 {
1602 if (mask->rank == 0)
1603 name = "sproduct";
1604 else
1605 name = "mproduct";
1606
1607 /* The mask can be kind 4 or 8 for the array case. For the
1608 scalar case, coerce it to default kind unconditionally. */
1609 if ((mask->ts.kind < gfc_default_logical_kind)
1610 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1611 {
1612 gfc_typespec ts;
1613 ts.type = BT_LOGICAL;
1614 ts.kind = gfc_default_logical_kind;
1615 gfc_convert_type_warn (mask, &ts, 2, 0);
1616 }
1617 }
1618 else
1619 name = "product";
1620
1621 f->value.function.name =
1622 gfc_get_string (PREFIX("%s_%c%d"), name,
1623 gfc_type_letter (array->ts.type), array->ts.kind);
1624 }
1625
1626
1627 void
1628 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1629 {
1630 f->ts.type = BT_REAL;
1631
1632 if (kind != NULL)
1633 f->ts.kind = mpz_get_si (kind->value.integer);
1634 else
1635 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1636 a->ts.kind : gfc_default_real_kind;
1637
1638 f->value.function.name =
1639 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1640 gfc_type_letter (a->ts.type), a->ts.kind);
1641 }
1642
1643
1644 void
1645 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1646 {
1647 f->ts.type = BT_REAL;
1648 f->ts.kind = a->ts.kind;
1649 f->value.function.name =
1650 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1651 gfc_type_letter (a->ts.type), a->ts.kind);
1652 }
1653
1654
1655 void
1656 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1657 gfc_expr * p2 ATTRIBUTE_UNUSED)
1658 {
1659 f->ts.type = BT_INTEGER;
1660 f->ts.kind = gfc_default_integer_kind;
1661 f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1662 }
1663
1664
1665 void
1666 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1667 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1668 {
1669 f->ts.type = BT_CHARACTER;
1670 f->ts.kind = string->ts.kind;
1671 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1672 }
1673
1674
1675 void
1676 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1677 gfc_expr * pad ATTRIBUTE_UNUSED,
1678 gfc_expr * order ATTRIBUTE_UNUSED)
1679 {
1680 mpz_t rank;
1681 int kind;
1682 int i;
1683
1684 f->ts = source->ts;
1685
1686 gfc_array_size (shape, &rank);
1687 f->rank = mpz_get_si (rank);
1688 mpz_clear (rank);
1689 switch (source->ts.type)
1690 {
1691 case BT_COMPLEX:
1692 case BT_REAL:
1693 case BT_INTEGER:
1694 case BT_LOGICAL:
1695 kind = source->ts.kind;
1696 break;
1697
1698 default:
1699 kind = 0;
1700 break;
1701 }
1702
1703 switch (kind)
1704 {
1705 case 4:
1706 case 8:
1707 case 10:
1708 case 16:
1709 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1710 f->value.function.name =
1711 gfc_get_string (PREFIX("reshape_%c%d"),
1712 gfc_type_letter (source->ts.type), source->ts.kind);
1713 else
1714 f->value.function.name =
1715 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1716
1717 break;
1718
1719 default:
1720 f->value.function.name = (source->ts.type == BT_CHARACTER
1721 ? PREFIX("reshape_char")
1722 : PREFIX("reshape"));
1723 break;
1724 }
1725
1726 /* TODO: Make this work with a constant ORDER parameter. */
1727 if (shape->expr_type == EXPR_ARRAY
1728 && gfc_is_constant_expr (shape)
1729 && order == NULL)
1730 {
1731 gfc_constructor *c;
1732 f->shape = gfc_get_shape (f->rank);
1733 c = shape->value.constructor;
1734 for (i = 0; i < f->rank; i++)
1735 {
1736 mpz_init_set (f->shape[i], c->expr->value.integer);
1737 c = c->next;
1738 }
1739 }
1740
1741 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1742 so many runtime variations. */
1743 if (shape->ts.kind != gfc_index_integer_kind)
1744 {
1745 gfc_typespec ts = shape->ts;
1746 ts.kind = gfc_index_integer_kind;
1747 gfc_convert_type_warn (shape, &ts, 2, 0);
1748 }
1749 if (order && order->ts.kind != gfc_index_integer_kind)
1750 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1751 }
1752
1753
1754 void
1755 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1756 {
1757 int k;
1758 gfc_actual_arglist *prec;
1759
1760 f->ts = x->ts;
1761 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1762
1763 /* Create a hidden argument to the library routines for rrspacing. This
1764 hidden argument is the precision of x. */
1765 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1766 prec = gfc_get_actual_arglist ();
1767 prec->name = "p";
1768 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
1769 f->value.function.actual->next = prec;
1770 }
1771
1772
1773 void
1774 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1775 {
1776 f->ts = x->ts;
1777
1778 /* The implementation calls scalbn which takes an int as the
1779 second argument. */
1780 if (i->ts.kind != gfc_c_int_kind)
1781 {
1782 gfc_typespec ts;
1783
1784 ts.type = BT_INTEGER;
1785 ts.kind = gfc_default_integer_kind;
1786
1787 gfc_convert_type_warn (i, &ts, 2, 0);
1788 }
1789
1790 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1791 }
1792
1793
1794 void
1795 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1796 gfc_expr * set ATTRIBUTE_UNUSED,
1797 gfc_expr * back ATTRIBUTE_UNUSED)
1798 {
1799 f->ts.type = BT_INTEGER;
1800 f->ts.kind = gfc_default_integer_kind;
1801 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1802 }
1803
1804
1805 void
1806 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1807 {
1808 t1->ts = t0->ts;
1809 t1->value.function.name =
1810 gfc_get_string (PREFIX("secnds"));
1811 }
1812
1813
1814 void
1815 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1816 {
1817 f->ts = x->ts;
1818
1819 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1820 convert type so we don't have to implement all possible
1821 permutations. */
1822 if (i->ts.kind != 4)
1823 {
1824 gfc_typespec ts;
1825
1826 ts.type = BT_INTEGER;
1827 ts.kind = gfc_default_integer_kind;
1828
1829 gfc_convert_type_warn (i, &ts, 2, 0);
1830 }
1831
1832 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1833 }
1834
1835
1836 void
1837 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1838 {
1839 f->ts.type = BT_INTEGER;
1840 f->ts.kind = gfc_default_integer_kind;
1841 f->rank = 1;
1842 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1843 f->shape = gfc_get_shape (1);
1844 mpz_init_set_ui (f->shape[0], array->rank);
1845 }
1846
1847
1848 void
1849 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1850 {
1851 f->ts = a->ts;
1852 f->value.function.name =
1853 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1854 }
1855
1856
1857 void
1858 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1859 {
1860 f->ts.type = BT_INTEGER;
1861 f->ts.kind = gfc_c_int_kind;
1862
1863 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1864 if (handler->ts.type == BT_INTEGER)
1865 {
1866 if (handler->ts.kind != gfc_c_int_kind)
1867 gfc_convert_type (handler, &f->ts, 2);
1868 f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1869 }
1870 else
1871 f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1872
1873 if (number->ts.kind != gfc_c_int_kind)
1874 gfc_convert_type (number, &f->ts, 2);
1875 }
1876
1877
1878 void
1879 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1880 {
1881 f->ts = x->ts;
1882 f->value.function.name =
1883 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1884 }
1885
1886
1887 void
1888 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1889 {
1890 f->ts = x->ts;
1891 f->value.function.name =
1892 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1893 }
1894
1895
1896 void
1897 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1898 {
1899 int k;
1900 gfc_actual_arglist *prec, *tiny, *emin_1;
1901
1902 f->ts = x->ts;
1903 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1904
1905 /* Create hidden arguments to the library routine for spacing. These
1906 hidden arguments are tiny(x), min_exponent - 1, and the precision
1907 of x. */
1908
1909 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1910
1911 tiny = gfc_get_actual_arglist ();
1912 tiny->name = "tiny";
1913 tiny->expr = gfc_get_expr ();
1914 tiny->expr->expr_type = EXPR_CONSTANT;
1915 tiny->expr->where = gfc_current_locus;
1916 tiny->expr->ts.type = x->ts.type;
1917 tiny->expr->ts.kind = x->ts.kind;
1918 mpfr_init (tiny->expr->value.real);
1919 mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
1920
1921 emin_1 = gfc_get_actual_arglist ();
1922 emin_1->name = "emin";
1923 emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
1924 emin_1->next = tiny;
1925
1926 prec = gfc_get_actual_arglist ();
1927 prec->name = "prec";
1928 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
1929 prec->next = emin_1;
1930
1931 f->value.function.actual->next = prec;
1932
1933 }
1934
1935
1936 void
1937 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1938 gfc_expr * dim,
1939 gfc_expr * ncopies)
1940 {
1941 if (source->ts.type == BT_CHARACTER)
1942 check_charlen_present (source);
1943
1944 f->ts = source->ts;
1945 f->rank = source->rank + 1;
1946 if (source->rank == 0)
1947 f->value.function.name = (source->ts.type == BT_CHARACTER
1948 ? PREFIX("spread_char_scalar")
1949 : PREFIX("spread_scalar"));
1950 else
1951 f->value.function.name = (source->ts.type == BT_CHARACTER
1952 ? PREFIX("spread_char")
1953 : PREFIX("spread"));
1954
1955 if (dim && gfc_is_constant_expr (dim)
1956 && ncopies && gfc_is_constant_expr (ncopies)
1957 && source->shape[0])
1958 {
1959 int i, idim;
1960 idim = mpz_get_ui (dim->value.integer);
1961 f->shape = gfc_get_shape (f->rank);
1962 for (i = 0; i < (idim - 1); i++)
1963 mpz_init_set (f->shape[i], source->shape[i]);
1964
1965 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
1966
1967 for (i = idim; i < f->rank ; i++)
1968 mpz_init_set (f->shape[i], source->shape[i-1]);
1969 }
1970
1971
1972 gfc_resolve_dim_arg (dim);
1973 gfc_resolve_index (ncopies, 1);
1974 }
1975
1976
1977 void
1978 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1979 {
1980 f->ts = x->ts;
1981 f->value.function.name =
1982 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1983 }
1984
1985
1986 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1987
1988 void
1989 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1990 gfc_expr * a ATTRIBUTE_UNUSED)
1991 {
1992 f->ts.type = BT_INTEGER;
1993 f->ts.kind = gfc_default_integer_kind;
1994 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1995 }
1996
1997
1998 void
1999 gfc_resolve_lstat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
2000 gfc_expr * a ATTRIBUTE_UNUSED)
2001 {
2002 f->ts.type = BT_INTEGER;
2003 f->ts.kind = gfc_default_integer_kind;
2004 f->value.function.name = gfc_get_string (PREFIX("lstat_i%d"), f->ts.kind);
2005 }
2006
2007
2008 void
2009 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
2010 {
2011 f->ts.type = BT_INTEGER;
2012 f->ts.kind = gfc_default_integer_kind;
2013 if (n->ts.kind != f->ts.kind)
2014 gfc_convert_type (n, &f->ts, 2);
2015
2016 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
2017 }
2018
2019
2020 void
2021 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
2022 {
2023 gfc_typespec ts;
2024
2025 f->ts.type = BT_INTEGER;
2026 f->ts.kind = gfc_c_int_kind;
2027 if (u->ts.kind != gfc_c_int_kind)
2028 {
2029 ts.type = BT_INTEGER;
2030 ts.kind = gfc_c_int_kind;
2031 ts.derived = NULL;
2032 ts.cl = NULL;
2033 gfc_convert_type (u, &ts, 2);
2034 }
2035
2036 f->value.function.name = gfc_get_string (PREFIX("fgetc"));
2037 }
2038
2039
2040 void
2041 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
2042 {
2043 f->ts.type = BT_INTEGER;
2044 f->ts.kind = gfc_c_int_kind;
2045 f->value.function.name = gfc_get_string (PREFIX("fget"));
2046 }
2047
2048
2049 void
2050 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
2051 {
2052 gfc_typespec ts;
2053
2054 f->ts.type = BT_INTEGER;
2055 f->ts.kind = gfc_c_int_kind;
2056 if (u->ts.kind != gfc_c_int_kind)
2057 {
2058 ts.type = BT_INTEGER;
2059 ts.kind = gfc_c_int_kind;
2060 ts.derived = NULL;
2061 ts.cl = NULL;
2062 gfc_convert_type (u, &ts, 2);
2063 }
2064
2065 f->value.function.name = gfc_get_string (PREFIX("fputc"));
2066 }
2067
2068
2069 void
2070 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
2071 {
2072 f->ts.type = BT_INTEGER;
2073 f->ts.kind = gfc_c_int_kind;
2074 f->value.function.name = gfc_get_string (PREFIX("fput"));
2075 }
2076
2077
2078 void
2079 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
2080 {
2081 gfc_typespec ts;
2082
2083 f->ts.type = BT_INTEGER;
2084 f->ts.kind = gfc_index_integer_kind;
2085 if (u->ts.kind != gfc_c_int_kind)
2086 {
2087 ts.type = BT_INTEGER;
2088 ts.kind = gfc_c_int_kind;
2089 ts.derived = NULL;
2090 ts.cl = NULL;
2091 gfc_convert_type (u, &ts, 2);
2092 }
2093
2094 f->value.function.name = gfc_get_string (PREFIX("ftell"));
2095 }
2096
2097
2098 void
2099 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
2100 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,
2285 gfc_expr * dim)
2286 {
2287 static char ubound[] = "__ubound";
2288
2289 f->ts.type = BT_INTEGER;
2290 f->ts.kind = gfc_default_integer_kind;
2291
2292 if (dim == NULL)
2293 {
2294 f->rank = 1;
2295 f->shape = gfc_get_shape (1);
2296 mpz_init_set_ui (f->shape[0], array->rank);
2297 }
2298
2299 f->value.function.name = ubound;
2300 }
2301
2302
2303 /* Resolve the g77 compatibility function UMASK. */
2304
2305 void
2306 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
2307 {
2308 f->ts.type = BT_INTEGER;
2309 f->ts.kind = n->ts.kind;
2310 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
2311 }
2312
2313
2314 /* Resolve the g77 compatibility function UNLINK. */
2315
2316 void
2317 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2318 {
2319 f->ts.type = BT_INTEGER;
2320 f->ts.kind = 4;
2321 f->value.function.name = gfc_get_string (PREFIX("unlink"));
2322 }
2323
2324
2325 void
2326 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
2327 {
2328 gfc_typespec ts;
2329
2330 f->ts.type = BT_CHARACTER;
2331 f->ts.kind = gfc_default_character_kind;
2332
2333 if (unit->ts.kind != gfc_c_int_kind)
2334 {
2335 ts.type = BT_INTEGER;
2336 ts.kind = gfc_c_int_kind;
2337 ts.derived = NULL;
2338 ts.cl = NULL;
2339 gfc_convert_type (unit, &ts, 2);
2340 }
2341
2342 f->value.function.name = gfc_get_string (PREFIX("ttynam"));
2343 }
2344
2345
2346 void
2347 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
2348 gfc_expr * field ATTRIBUTE_UNUSED)
2349 {
2350 f->ts = vector->ts;
2351 f->rank = mask->rank;
2352
2353 f->value.function.name =
2354 gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
2355 vector->ts.type == BT_CHARACTER ? "_char" : "");
2356 }
2357
2358
2359 void
2360 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
2361 gfc_expr * set ATTRIBUTE_UNUSED,
2362 gfc_expr * back ATTRIBUTE_UNUSED)
2363 {
2364 f->ts.type = BT_INTEGER;
2365 f->ts.kind = gfc_default_integer_kind;
2366 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2367 }
2368
2369
2370 void
2371 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
2372 {
2373 f->ts.type = i->ts.type;
2374 f->ts.kind = gfc_kind_max (i,j);
2375
2376 if (i->ts.kind != j->ts.kind)
2377 {
2378 if (i->ts.kind == gfc_kind_max (i,j))
2379 gfc_convert_type(j, &i->ts, 2);
2380 else
2381 gfc_convert_type(i, &j->ts, 2);
2382 }
2383
2384 f->value.function.name = gfc_get_string ("__xor_%c%d",
2385 gfc_type_letter (i->ts.type),
2386 f->ts.kind);
2387 }
2388
2389
2390 /* Intrinsic subroutine resolution. */
2391
2392 void
2393 gfc_resolve_alarm_sub (gfc_code * c)
2394 {
2395 const char *name;
2396 gfc_expr *seconds, *handler, *status;
2397 gfc_typespec ts;
2398
2399 seconds = c->ext.actual->expr;
2400 handler = c->ext.actual->next->expr;
2401 status = c->ext.actual->next->next->expr;
2402 ts.type = BT_INTEGER;
2403 ts.kind = gfc_c_int_kind;
2404
2405 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2406 if (handler->ts.type == BT_INTEGER)
2407 {
2408 if (handler->ts.kind != gfc_c_int_kind)
2409 gfc_convert_type (handler, &ts, 2);
2410 name = gfc_get_string (PREFIX("alarm_sub_int"));
2411 }
2412 else
2413 name = gfc_get_string (PREFIX("alarm_sub"));
2414
2415 if (seconds->ts.kind != gfc_c_int_kind)
2416 gfc_convert_type (seconds, &ts, 2);
2417 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2418 gfc_convert_type (status, &ts, 2);
2419
2420 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2421 }
2422
2423 void
2424 gfc_resolve_cpu_time (gfc_code * c)
2425 {
2426 const char *name;
2427
2428 name = gfc_get_string (PREFIX("cpu_time_%d"),
2429 c->ext.actual->expr->ts.kind);
2430 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2431 }
2432
2433
2434 void
2435 gfc_resolve_mvbits (gfc_code * c)
2436 {
2437 const char *name;
2438 int kind;
2439
2440 kind = c->ext.actual->expr->ts.kind;
2441 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2442
2443 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2444 }
2445
2446
2447 void
2448 gfc_resolve_random_number (gfc_code * c)
2449 {
2450 const char *name;
2451 int kind;
2452
2453 kind = c->ext.actual->expr->ts.kind;
2454 if (c->ext.actual->expr->rank == 0)
2455 name = gfc_get_string (PREFIX("random_r%d"), kind);
2456 else
2457 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2458
2459 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2460 }
2461
2462
2463 void
2464 gfc_resolve_rename_sub (gfc_code * c)
2465 {
2466 const char *name;
2467 int kind;
2468
2469 if (c->ext.actual->next->next->expr != NULL)
2470 kind = c->ext.actual->next->next->expr->ts.kind;
2471 else
2472 kind = gfc_default_integer_kind;
2473
2474 name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2475 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2476 }
2477
2478
2479 void
2480 gfc_resolve_kill_sub (gfc_code * c)
2481 {
2482 const char *name;
2483 int kind;
2484
2485 if (c->ext.actual->next->next->expr != NULL)
2486 kind = c->ext.actual->next->next->expr->ts.kind;
2487 else
2488 kind = gfc_default_integer_kind;
2489
2490 name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2491 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2492 }
2493
2494
2495 void
2496 gfc_resolve_link_sub (gfc_code * c)
2497 {
2498 const char *name;
2499 int kind;
2500
2501 if (c->ext.actual->next->next->expr != NULL)
2502 kind = c->ext.actual->next->next->expr->ts.kind;
2503 else
2504 kind = gfc_default_integer_kind;
2505
2506 name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2507 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2508 }
2509
2510
2511 void
2512 gfc_resolve_symlnk_sub (gfc_code * c)
2513 {
2514 const char *name;
2515 int kind;
2516
2517 if (c->ext.actual->next->next->expr != NULL)
2518 kind = c->ext.actual->next->next->expr->ts.kind;
2519 else
2520 kind = gfc_default_integer_kind;
2521
2522 name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2523 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2524 }
2525
2526
2527 /* G77 compatibility subroutines etime() and dtime(). */
2528
2529 void
2530 gfc_resolve_etime_sub (gfc_code * c)
2531 {
2532 const char *name;
2533
2534 name = gfc_get_string (PREFIX("etime_sub"));
2535 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2536 }
2537
2538
2539 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2540
2541 void
2542 gfc_resolve_itime (gfc_code * c)
2543 {
2544 c->resolved_sym = gfc_get_intrinsic_sub_symbol
2545 (gfc_get_string (PREFIX("itime_i%d"),
2546 gfc_default_integer_kind));
2547 }
2548
2549 void
2550 gfc_resolve_idate (gfc_code * c)
2551 {
2552 c->resolved_sym = gfc_get_intrinsic_sub_symbol
2553 (gfc_get_string (PREFIX("idate_i%d"),
2554 gfc_default_integer_kind));
2555 }
2556
2557 void
2558 gfc_resolve_ltime (gfc_code * c)
2559 {
2560 c->resolved_sym = gfc_get_intrinsic_sub_symbol
2561 (gfc_get_string (PREFIX("ltime_i%d"),
2562 gfc_default_integer_kind));
2563 }
2564
2565 void
2566 gfc_resolve_gmtime (gfc_code * c)
2567 {
2568 c->resolved_sym = gfc_get_intrinsic_sub_symbol
2569 (gfc_get_string (PREFIX("gmtime_i%d"),
2570 gfc_default_integer_kind));
2571 }
2572
2573
2574 /* G77 compatibility subroutine second(). */
2575
2576 void
2577 gfc_resolve_second_sub (gfc_code * c)
2578 {
2579 const char *name;
2580
2581 name = gfc_get_string (PREFIX("second_sub"));
2582 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2583 }
2584
2585
2586 void
2587 gfc_resolve_sleep_sub (gfc_code * c)
2588 {
2589 const char *name;
2590 int kind;
2591
2592 if (c->ext.actual->expr != NULL)
2593 kind = c->ext.actual->expr->ts.kind;
2594 else
2595 kind = gfc_default_integer_kind;
2596
2597 name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2598 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2599 }
2600
2601
2602 /* G77 compatibility function srand(). */
2603
2604 void
2605 gfc_resolve_srand (gfc_code * c)
2606 {
2607 const char *name;
2608 name = gfc_get_string (PREFIX("srand"));
2609 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2610 }
2611
2612
2613 /* Resolve the getarg intrinsic subroutine. */
2614
2615 void
2616 gfc_resolve_getarg (gfc_code * c)
2617 {
2618 const char *name;
2619 int kind;
2620
2621 kind = gfc_default_integer_kind;
2622 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2623 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2624 }
2625
2626 /* Resolve the getcwd intrinsic subroutine. */
2627
2628 void
2629 gfc_resolve_getcwd_sub (gfc_code * c)
2630 {
2631 const char *name;
2632 int kind;
2633
2634 if (c->ext.actual->next->expr != NULL)
2635 kind = c->ext.actual->next->expr->ts.kind;
2636 else
2637 kind = gfc_default_integer_kind;
2638
2639 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2640 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2641 }
2642
2643
2644 /* Resolve the get_command intrinsic subroutine. */
2645
2646 void
2647 gfc_resolve_get_command (gfc_code * c)
2648 {
2649 const char *name;
2650 int kind;
2651
2652 kind = gfc_default_integer_kind;
2653 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2654 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2655 }
2656
2657
2658 /* Resolve the get_command_argument intrinsic subroutine. */
2659
2660 void
2661 gfc_resolve_get_command_argument (gfc_code * c)
2662 {
2663 const char *name;
2664 int kind;
2665
2666 kind = gfc_default_integer_kind;
2667 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2668 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2669 }
2670
2671 /* Resolve the get_environment_variable intrinsic subroutine. */
2672
2673 void
2674 gfc_resolve_get_environment_variable (gfc_code * code)
2675 {
2676 const char *name;
2677 int kind;
2678
2679 kind = gfc_default_integer_kind;
2680 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2681 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2682 }
2683
2684 void
2685 gfc_resolve_signal_sub (gfc_code * c)
2686 {
2687 const char *name;
2688 gfc_expr *number, *handler, *status;
2689 gfc_typespec ts;
2690
2691 number = c->ext.actual->expr;
2692 handler = c->ext.actual->next->expr;
2693 status = c->ext.actual->next->next->expr;
2694 ts.type = BT_INTEGER;
2695 ts.kind = gfc_c_int_kind;
2696
2697 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2698 if (handler->ts.type == BT_INTEGER)
2699 {
2700 if (handler->ts.kind != gfc_c_int_kind)
2701 gfc_convert_type (handler, &ts, 2);
2702 name = gfc_get_string (PREFIX("signal_sub_int"));
2703 }
2704 else
2705 name = gfc_get_string (PREFIX("signal_sub"));
2706
2707 if (number->ts.kind != gfc_c_int_kind)
2708 gfc_convert_type (number, &ts, 2);
2709 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2710 gfc_convert_type (status, &ts, 2);
2711
2712 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2713 }
2714
2715 /* Resolve the SYSTEM intrinsic subroutine. */
2716
2717 void
2718 gfc_resolve_system_sub (gfc_code * c)
2719 {
2720 const char *name;
2721
2722 name = gfc_get_string (PREFIX("system_sub"));
2723 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2724 }
2725
2726 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2727
2728 void
2729 gfc_resolve_system_clock (gfc_code * c)
2730 {
2731 const char *name;
2732 int kind;
2733
2734 if (c->ext.actual->expr != NULL)
2735 kind = c->ext.actual->expr->ts.kind;
2736 else if (c->ext.actual->next->expr != NULL)
2737 kind = c->ext.actual->next->expr->ts.kind;
2738 else if (c->ext.actual->next->next->expr != NULL)
2739 kind = c->ext.actual->next->next->expr->ts.kind;
2740 else
2741 kind = gfc_default_integer_kind;
2742
2743 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2744 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2745 }
2746
2747 /* Resolve the EXIT intrinsic subroutine. */
2748
2749 void
2750 gfc_resolve_exit (gfc_code * c)
2751 {
2752 const char *name;
2753 int kind;
2754
2755 if (c->ext.actual->expr != NULL)
2756 kind = c->ext.actual->expr->ts.kind;
2757 else
2758 kind = gfc_default_integer_kind;
2759
2760 name = gfc_get_string (PREFIX("exit_i%d"), kind);
2761 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2762 }
2763
2764 /* Resolve the FLUSH intrinsic subroutine. */
2765
2766 void
2767 gfc_resolve_flush (gfc_code * c)
2768 {
2769 const char *name;
2770 gfc_typespec ts;
2771 gfc_expr *n;
2772
2773 ts.type = BT_INTEGER;
2774 ts.kind = gfc_default_integer_kind;
2775 n = c->ext.actual->expr;
2776 if (n != NULL
2777 && n->ts.kind != ts.kind)
2778 gfc_convert_type (n, &ts, 2);
2779
2780 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2781 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2782 }
2783
2784
2785 void
2786 gfc_resolve_free (gfc_code * c)
2787 {
2788 gfc_typespec ts;
2789 gfc_expr *n;
2790
2791 ts.type = BT_INTEGER;
2792 ts.kind = gfc_index_integer_kind;
2793 n = c->ext.actual->expr;
2794 if (n->ts.kind != ts.kind)
2795 gfc_convert_type (n, &ts, 2);
2796
2797 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2798 }
2799
2800
2801 void
2802 gfc_resolve_ctime_sub (gfc_code * c)
2803 {
2804 gfc_typespec ts;
2805
2806 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2807 if (c->ext.actual->expr->ts.kind != 8)
2808 {
2809 ts.type = BT_INTEGER;
2810 ts.kind = 8;
2811 ts.derived = NULL;
2812 ts.cl = NULL;
2813 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2814 }
2815
2816 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2817 }
2818
2819
2820 void
2821 gfc_resolve_fdate_sub (gfc_code * c)
2822 {
2823 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2824 }
2825
2826
2827 void
2828 gfc_resolve_gerror (gfc_code * c)
2829 {
2830 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2831 }
2832
2833
2834 void
2835 gfc_resolve_getlog (gfc_code * c)
2836 {
2837 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2838 }
2839
2840
2841 void
2842 gfc_resolve_hostnm_sub (gfc_code * c)
2843 {
2844 const char *name;
2845 int kind;
2846
2847 if (c->ext.actual->next->expr != NULL)
2848 kind = c->ext.actual->next->expr->ts.kind;
2849 else
2850 kind = gfc_default_integer_kind;
2851
2852 name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2853 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2854 }
2855
2856
2857 void
2858 gfc_resolve_perror (gfc_code * c)
2859 {
2860 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2861 }
2862
2863 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2864
2865 void
2866 gfc_resolve_stat_sub (gfc_code * c)
2867 {
2868 const char *name;
2869
2870 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2871 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2872 }
2873
2874
2875 void
2876 gfc_resolve_lstat_sub (gfc_code * c)
2877 {
2878 const char *name;
2879
2880 name = gfc_get_string (PREFIX("lstat_i%d_sub"), gfc_default_integer_kind);
2881 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2882 }
2883
2884
2885 void
2886 gfc_resolve_fstat_sub (gfc_code * c)
2887 {
2888 const char *name;
2889 gfc_expr *u;
2890 gfc_typespec *ts;
2891
2892 u = c->ext.actual->expr;
2893 ts = &c->ext.actual->next->expr->ts;
2894 if (u->ts.kind != ts->kind)
2895 gfc_convert_type (u, ts, 2);
2896 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2897 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2898 }
2899
2900
2901 void
2902 gfc_resolve_fgetc_sub (gfc_code * c)
2903 {
2904 const char *name;
2905 gfc_typespec ts;
2906 gfc_expr *u, *st;
2907
2908 u = c->ext.actual->expr;
2909 st = c->ext.actual->next->next->expr;
2910
2911 if (u->ts.kind != gfc_c_int_kind)
2912 {
2913 ts.type = BT_INTEGER;
2914 ts.kind = gfc_c_int_kind;
2915 ts.derived = NULL;
2916 ts.cl = NULL;
2917 gfc_convert_type (u, &ts, 2);
2918 }
2919
2920 if (st != NULL)
2921 name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2922 else
2923 name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2924
2925 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2926 }
2927
2928
2929 void
2930 gfc_resolve_fget_sub (gfc_code * c)
2931 {
2932 const char *name;
2933 gfc_expr *st;
2934
2935 st = c->ext.actual->next->expr;
2936 if (st != NULL)
2937 name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2938 else
2939 name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2940
2941 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2942 }
2943
2944
2945 void
2946 gfc_resolve_fputc_sub (gfc_code * c)
2947 {
2948 const char *name;
2949 gfc_typespec ts;
2950 gfc_expr *u, *st;
2951
2952 u = c->ext.actual->expr;
2953 st = c->ext.actual->next->next->expr;
2954
2955 if (u->ts.kind != gfc_c_int_kind)
2956 {
2957 ts.type = BT_INTEGER;
2958 ts.kind = gfc_c_int_kind;
2959 ts.derived = NULL;
2960 ts.cl = NULL;
2961 gfc_convert_type (u, &ts, 2);
2962 }
2963
2964 if (st != NULL)
2965 name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2966 else
2967 name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2968
2969 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2970 }
2971
2972
2973 void
2974 gfc_resolve_fput_sub (gfc_code * c)
2975 {
2976 const char *name;
2977 gfc_expr *st;
2978
2979 st = c->ext.actual->next->expr;
2980 if (st != NULL)
2981 name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2982 else
2983 name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2984
2985 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2986 }
2987
2988
2989 void
2990 gfc_resolve_ftell_sub (gfc_code * c)
2991 {
2992 const char *name;
2993 gfc_expr *unit;
2994 gfc_expr *offset;
2995 gfc_typespec ts;
2996
2997 unit = c->ext.actual->expr;
2998 offset = c->ext.actual->next->expr;
2999
3000 if (unit->ts.kind != gfc_c_int_kind)
3001 {
3002 ts.type = BT_INTEGER;
3003 ts.kind = gfc_c_int_kind;
3004 ts.derived = NULL;
3005 ts.cl = NULL;
3006 gfc_convert_type (unit, &ts, 2);
3007 }
3008
3009 name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
3010 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3011 }
3012
3013
3014 void
3015 gfc_resolve_ttynam_sub (gfc_code * c)
3016 {
3017 gfc_typespec ts;
3018
3019 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3020 {
3021 ts.type = BT_INTEGER;
3022 ts.kind = gfc_c_int_kind;
3023 ts.derived = NULL;
3024 ts.cl = NULL;
3025 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3026 }
3027
3028 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
3029 }
3030
3031
3032 /* Resolve the UMASK intrinsic subroutine. */
3033
3034 void
3035 gfc_resolve_umask_sub (gfc_code * c)
3036 {
3037 const char *name;
3038 int kind;
3039
3040 if (c->ext.actual->next->expr != NULL)
3041 kind = c->ext.actual->next->expr->ts.kind;
3042 else
3043 kind = gfc_default_integer_kind;
3044
3045 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
3046 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3047 }
3048
3049 /* Resolve the UNLINK intrinsic subroutine. */
3050
3051 void
3052 gfc_resolve_unlink_sub (gfc_code * c)
3053 {
3054 const char *name;
3055 int kind;
3056
3057 if (c->ext.actual->next->expr != NULL)
3058 kind = c->ext.actual->next->expr->ts.kind;
3059 else
3060 kind = gfc_default_integer_kind;
3061
3062 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
3063 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3064 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org