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