?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR other/22202
[official-gcc.git] / gcc / fortran / iresolve.c
blob195f05ed990e3635bb1c4284ad91549594bcb18d
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 /********************** Resolution functions **********************/
63
64
65 void
66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
67 {
68 f->ts = a->ts;
69 if (f->ts.type == BT_COMPLEX)
70 f->ts.type = BT_REAL;
71
72 f->value.function.name =
73 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
74 }
75
76
77 void
78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
79 {
80 f->ts = x->ts;
81 f->value.function.name =
82 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
83 }
84
85
86 void
87 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
88 {
89 f->ts = x->ts;
90 f->value.function.name =
91 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
92 }
93
94
95 void
96 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
97 {
98 f->ts.type = BT_REAL;
99 f->ts.kind = x->ts.kind;
100 f->value.function.name =
101 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
102 }
103
104
105 void
106 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
107 {
108 f->ts.type = a->ts.type;
109 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
110
111 /* The resolved name is only used for specific intrinsics where
112 the return kind is the same as the arg kind. */
113 f->value.function.name =
114 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
115 }
116
117
118 void
119 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
120 {
121 gfc_resolve_aint (f, a, NULL);
122 }
123
124
125 void
126 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
127 {
128 f->ts = mask->ts;
129
130 if (dim != NULL)
131 {
132 gfc_resolve_dim_arg (dim);
133 f->rank = mask->rank - 1;
134 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
135 }
136
137 f->value.function.name =
138 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
139 mask->ts.kind);
140 }
141
142
143 void
144 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
145 {
146 f->ts.type = a->ts.type;
147 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
148
149 /* The resolved name is only used for specific intrinsics where
150 the return kind is the same as the arg kind. */
151 f->value.function.name =
152 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
153 }
154
155
156 void
157 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
158 {
159 gfc_resolve_anint (f, a, NULL);
160 }
161
162
163 void
164 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
165 {
166 f->ts = mask->ts;
167
168 if (dim != NULL)
169 {
170 gfc_resolve_dim_arg (dim);
171 f->rank = mask->rank - 1;
172 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
173 }
174
175 f->value.function.name =
176 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
177 mask->ts.kind);
178 }
179
180
181 void
182 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
183 {
184 f->ts = x->ts;
185 f->value.function.name =
186 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
187 }
188
189 void
190 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
191 {
192 f->ts = x->ts;
193 f->value.function.name =
194 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
195 }
196
197 void
198 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
199 {
200 f->ts = x->ts;
201 f->value.function.name =
202 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
203 }
204
205 void
206 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
207 {
208 f->ts = x->ts;
209 f->value.function.name =
210 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
211 }
212
213 void
214 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
215 gfc_expr * y ATTRIBUTE_UNUSED)
216 {
217 f->ts = x->ts;
218 f->value.function.name =
219 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
220 }
221
222
223 /* Resolve the BESYN and BESJN intrinsics. */
224
225 void
226 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
227 {
228 gfc_typespec ts;
229
230 f->ts = x->ts;
231 if (n->ts.kind != gfc_c_int_kind)
232 {
233 ts.type = BT_INTEGER;
234 ts.kind = gfc_c_int_kind;
235 gfc_convert_type (n, &ts, 2);
236 }
237 f->value.function.name = gfc_get_string ("<intrinsic>");
238 }
239
240
241 void
242 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
243 {
244 f->ts.type = BT_LOGICAL;
245 f->ts.kind = gfc_default_logical_kind;
246
247 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
248 pos->ts.kind);
249 }
250
251
252 void
253 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
254 {
255 f->ts.type = BT_INTEGER;
256 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
257 : mpz_get_si (kind->value.integer);
258
259 f->value.function.name =
260 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
261 gfc_type_letter (a->ts.type), a->ts.kind);
262 }
263
264
265 void
266 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
267 {
268 f->ts.type = BT_CHARACTER;
269 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
270 : mpz_get_si (kind->value.integer);
271
272 f->value.function.name =
273 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
274 gfc_type_letter (a->ts.type), a->ts.kind);
275 }
276
277
278 void
279 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
280 {
281 f->ts.type = BT_INTEGER;
282 f->ts.kind = gfc_default_integer_kind;
283 f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
284 }
285
286
287 void
288 gfc_resolve_chdir_sub (gfc_code * c)
289 {
290 const char *name;
291 int kind;
292
293 if (c->ext.actual->next->expr != NULL)
294 kind = c->ext.actual->next->expr->ts.kind;
295 else
296 kind = gfc_default_integer_kind;
297
298 name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
299 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
300 }
301
302
303 void
304 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
305 {
306 f->ts.type = BT_COMPLEX;
307 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
308 : mpz_get_si (kind->value.integer);
309
310 if (y == NULL)
311 f->value.function.name =
312 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
313 gfc_type_letter (x->ts.type), x->ts.kind);
314 else
315 f->value.function.name =
316 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
317 gfc_type_letter (x->ts.type), x->ts.kind,
318 gfc_type_letter (y->ts.type), y->ts.kind);
319 }
320
321 void
322 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
323 {
324 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
325 }
326
327 void
328 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
329 {
330 f->ts = x->ts;
331 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
332 }
333
334
335 void
336 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
337 {
338 f->ts = x->ts;
339 f->value.function.name =
340 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
341 }
342
343
344 void
345 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
346 {
347 f->ts = x->ts;
348 f->value.function.name =
349 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
350 }
351
352
353 void
354 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
355 {
356 f->ts.type = BT_INTEGER;
357 f->ts.kind = gfc_default_integer_kind;
358
359 if (dim != NULL)
360 {
361 f->rank = mask->rank - 1;
362 gfc_resolve_dim_arg (dim);
363 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
364 }
365
366 f->value.function.name =
367 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
368 gfc_type_letter (mask->ts.type), mask->ts.kind);
369 }
370
371
372 void
373 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
374 gfc_expr * shift,
375 gfc_expr * dim)
376 {
377 int n;
378
379 f->ts = array->ts;
380 f->rank = array->rank;
381 f->shape = gfc_copy_shape (array->shape, array->rank);
382
383 if (shift->rank > 0)
384 n = 1;
385 else
386 n = 0;
387
388 /* Convert shift to at least gfc_default_integer_kind, so we don't need
389 kind=1 and kind=2 versions of the library functions. */
390 if (shift->ts.kind < gfc_default_integer_kind)
391 {
392 gfc_typespec ts;
393 ts.type = BT_INTEGER;
394 ts.kind = gfc_default_integer_kind;
395 gfc_convert_type_warn (shift, &ts, 2, 0);
396 }
397
398 if (dim != NULL)
399 {
400 gfc_resolve_dim_arg (dim);
401 /* Convert dim to shift's kind, so we don't need so many variations. */
402 if (dim->ts.kind != shift->ts.kind)
403 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
404 }
405 f->value.function.name =
406 gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
407 array->ts.type == BT_CHARACTER ? "_char" : "");
408 }
409
410
411 void
412 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
413 {
414 f->ts.type = BT_REAL;
415 f->ts.kind = gfc_default_double_kind;
416 f->value.function.name =
417 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
418 }
419
420
421 void
422 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
423 gfc_expr * y ATTRIBUTE_UNUSED)
424 {
425 f->ts = x->ts;
426 f->value.function.name =
427 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
428 }
429
430
431 void
432 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
433 {
434 gfc_expr temp;
435
436 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
437 {
438 f->ts.type = BT_LOGICAL;
439 f->ts.kind = gfc_default_logical_kind;
440 }
441 else
442 {
443 temp.expr_type = EXPR_OP;
444 gfc_clear_ts (&temp.ts);
445 temp.value.op.operator = INTRINSIC_NONE;
446 temp.value.op.op1 = a;
447 temp.value.op.op2 = b;
448 gfc_type_convert_binary (&temp);
449 f->ts = temp.ts;
450 }
451
452 f->value.function.name =
453 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
454 f->ts.kind);
455 }
456
457
458 void
459 gfc_resolve_dprod (gfc_expr * f,
460 gfc_expr * a ATTRIBUTE_UNUSED,
461 gfc_expr * b ATTRIBUTE_UNUSED)
462 {
463 f->ts.kind = gfc_default_double_kind;
464 f->ts.type = BT_REAL;
465
466 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
467 }
468
469
470 void
471 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
472 gfc_expr * shift,
473 gfc_expr * boundary,
474 gfc_expr * dim)
475 {
476 int n;
477
478 f->ts = array->ts;
479 f->rank = array->rank;
480 f->shape = gfc_copy_shape (array->shape, array->rank);
481
482 n = 0;
483 if (shift->rank > 0)
484 n = n | 1;
485 if (boundary && boundary->rank > 0)
486 n = n | 2;
487
488 /* Convert shift to at least gfc_default_integer_kind, so we don't need
489 kind=1 and kind=2 versions of the library functions. */
490 if (shift->ts.kind < gfc_default_integer_kind)
491 {
492 gfc_typespec ts;
493 ts.type = BT_INTEGER;
494 ts.kind = gfc_default_integer_kind;
495 gfc_convert_type_warn (shift, &ts, 2, 0);
496 }
497
498 if (dim != NULL)
499 {
500 gfc_resolve_dim_arg (dim);
501 /* Convert dim to shift's kind, so we don't need so many variations. */
502 if (dim->ts.kind != shift->ts.kind)
503 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
504 }
505
506 f->value.function.name =
507 gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
508 array->ts.type == BT_CHARACTER ? "_char" : "");
509 }
510
511
512 void
513 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
514 {
515 f->ts = x->ts;
516 f->value.function.name =
517 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
518 }
519
520
521 void
522 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
523 {
524 f->ts.type = BT_INTEGER;
525 f->ts.kind = gfc_default_integer_kind;
526
527 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
528 }
529
530
531 void
532 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
533 {
534 f->ts.type = BT_INTEGER;
535 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
536 : mpz_get_si (kind->value.integer);
537
538 f->value.function.name =
539 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
540 gfc_type_letter (a->ts.type), a->ts.kind);
541 }
542
543
544 void
545 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
546 {
547 f->ts.type = BT_INTEGER;
548 f->ts.kind = gfc_default_integer_kind;
549 if (n->ts.kind != f->ts.kind)
550 gfc_convert_type (n, &f->ts, 2);
551 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
552 }
553
554
555 void
556 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
557 {
558 f->ts = x->ts;
559 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
560 }
561
562
563 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
564
565 void
566 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
567 {
568 f->ts = x->ts;
569 f->value.function.name = gfc_get_string ("<intrinsic>");
570 }
571
572
573 void
574 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
575 {
576 f->ts.type = BT_INTEGER;
577 f->ts.kind = 4;
578 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
579 }
580
581
582 void
583 gfc_resolve_getgid (gfc_expr * f)
584 {
585 f->ts.type = BT_INTEGER;
586 f->ts.kind = 4;
587 f->value.function.name = gfc_get_string (PREFIX("getgid"));
588 }
589
590
591 void
592 gfc_resolve_getpid (gfc_expr * f)
593 {
594 f->ts.type = BT_INTEGER;
595 f->ts.kind = 4;
596 f->value.function.name = gfc_get_string (PREFIX("getpid"));
597 }
598
599
600 void
601 gfc_resolve_getuid (gfc_expr * f)
602 {
603 f->ts.type = BT_INTEGER;
604 f->ts.kind = 4;
605 f->value.function.name = gfc_get_string (PREFIX("getuid"));
606 }
607
608 void
609 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
610 {
611 f->ts.type = BT_INTEGER;
612 f->ts.kind = 4;
613 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
614 }
615
616 void
617 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
618 {
619 /* If the kind of i and j are different, then g77 cross-promoted the
620 kinds to the largest value. The Fortran 95 standard requires the
621 kinds to match. */
622 if (i->ts.kind != j->ts.kind)
623 {
624 if (i->ts.kind == gfc_kind_max (i,j))
625 gfc_convert_type(j, &i->ts, 2);
626 else
627 gfc_convert_type(i, &j->ts, 2);
628 }
629
630 f->ts = i->ts;
631 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
632 }
633
634
635 void
636 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
637 {
638 f->ts = i->ts;
639 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
640 }
641
642
643 void
644 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
645 gfc_expr * pos ATTRIBUTE_UNUSED,
646 gfc_expr * len ATTRIBUTE_UNUSED)
647 {
648 f->ts = i->ts;
649 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
650 }
651
652
653 void
654 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
655 gfc_expr * pos ATTRIBUTE_UNUSED)
656 {
657 f->ts = i->ts;
658 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
659 }
660
661
662 void
663 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
664 {
665 f->ts.type = BT_INTEGER;
666 f->ts.kind = gfc_default_integer_kind;
667
668 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
669 }
670
671
672 void
673 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
674 {
675 gfc_resolve_nint (f, a, NULL);
676 }
677
678
679 void
680 gfc_resolve_ierrno (gfc_expr * f)
681 {
682 f->ts.type = BT_INTEGER;
683 f->ts.kind = gfc_default_integer_kind;
684 f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
685 }
686
687
688 void
689 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
690 {
691 /* If the kind of i and j are different, then g77 cross-promoted the
692 kinds to the largest value. The Fortran 95 standard requires the
693 kinds to match. */
694 if (i->ts.kind != j->ts.kind)
695 {
696 if (i->ts.kind == gfc_kind_max (i,j))
697 gfc_convert_type(j, &i->ts, 2);
698 else
699 gfc_convert_type(i, &j->ts, 2);
700 }
701
702 f->ts = i->ts;
703 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
704 }
705
706
707 void
708 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
709 {
710 /* If the kind of i and j are different, then g77 cross-promoted the
711 kinds to the largest value. The Fortran 95 standard requires the
712 kinds to match. */
713 if (i->ts.kind != j->ts.kind)
714 {
715 if (i->ts.kind == gfc_kind_max (i,j))
716 gfc_convert_type(j, &i->ts, 2);
717 else
718 gfc_convert_type(i, &j->ts, 2);
719 }
720
721 f->ts = i->ts;
722 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
723 }
724
725
726 void
727 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
728 {
729 f->ts.type = BT_INTEGER;
730 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
731 : mpz_get_si (kind->value.integer);
732
733 f->value.function.name =
734 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
735 a->ts.kind);
736 }
737
738
739 void
740 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
741 {
742 gfc_typespec ts;
743
744 f->ts.type = BT_LOGICAL;
745 f->ts.kind = gfc_default_integer_kind;
746 if (u->ts.kind != gfc_c_int_kind)
747 {
748 ts.type = BT_INTEGER;
749 ts.kind = gfc_c_int_kind;
750 ts.derived = NULL;
751 ts.cl = NULL;
752 gfc_convert_type (u, &ts, 2);
753 }
754
755 f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
756 }
757
758
759 void
760 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
761 {
762 f->ts = i->ts;
763 f->value.function.name =
764 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
765 }
766
767
768 void
769 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
770 gfc_expr * size)
771 {
772 int s_kind;
773
774 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
775
776 f->ts = i->ts;
777 f->value.function.name =
778 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
779 }
780
781
782 void
783 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
784 ATTRIBUTE_UNUSED gfc_expr * s)
785 {
786 f->ts.type = BT_INTEGER;
787 f->ts.kind = gfc_default_integer_kind;
788
789 f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
790 }
791
792
793 void
794 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
795 gfc_expr * dim)
796 {
797 static char lbound[] = "__lbound";
798
799 f->ts.type = BT_INTEGER;
800 f->ts.kind = gfc_default_integer_kind;
801
802 if (dim == NULL)
803 {
804 f->rank = 1;
805 f->shape = gfc_get_shape (1);
806 mpz_init_set_ui (f->shape[0], array->rank);
807 }
808
809 f->value.function.name = lbound;
810 }
811
812
813 void
814 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
815 {
816 f->ts.type = BT_INTEGER;
817 f->ts.kind = gfc_default_integer_kind;
818 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
819 }
820
821
822 void
823 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
824 {
825 f->ts.type = BT_INTEGER;
826 f->ts.kind = gfc_default_integer_kind;
827 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
828 }
829
830
831 void
832 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
833 gfc_expr * p2 ATTRIBUTE_UNUSED)
834 {
835 f->ts.type = BT_INTEGER;
836 f->ts.kind = gfc_default_integer_kind;
837 f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
838 }
839
840
841 void
842 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
843 {
844 f->ts = x->ts;
845 f->value.function.name =
846 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
847 }
848
849
850 void
851 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
852 {
853 f->ts = x->ts;
854 f->value.function.name =
855 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
856 }
857
858
859 void
860 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
861 {
862 f->ts.type = BT_LOGICAL;
863 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
864 : mpz_get_si (kind->value.integer);
865 f->rank = a->rank;
866
867 f->value.function.name =
868 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
869 gfc_type_letter (a->ts.type), a->ts.kind);
870 }
871
872
873 void
874 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
875 {
876 gfc_expr temp;
877
878 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
879 {
880 f->ts.type = BT_LOGICAL;
881 f->ts.kind = gfc_default_logical_kind;
882 }
883 else
884 {
885 temp.expr_type = EXPR_OP;
886 gfc_clear_ts (&temp.ts);
887 temp.value.op.operator = INTRINSIC_NONE;
888 temp.value.op.op1 = a;
889 temp.value.op.op2 = b;
890 gfc_type_convert_binary (&temp);
891 f->ts = temp.ts;
892 }
893
894 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
895
896 f->value.function.name =
897 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
898 f->ts.kind);
899 }
900
901
902 static void
903 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
904 {
905 gfc_actual_arglist *a;
906
907 f->ts.type = args->expr->ts.type;
908 f->ts.kind = args->expr->ts.kind;
909 /* Find the largest type kind. */
910 for (a = args->next; a; a = a->next)
911 {
912 if (a->expr->ts.kind > f->ts.kind)
913 f->ts.kind = a->expr->ts.kind;
914 }
915
916 /* Convert all parameters to the required kind. */
917 for (a = args; a; a = a->next)
918 {
919 if (a->expr->ts.kind != f->ts.kind)
920 gfc_convert_type (a->expr, &f->ts, 2);
921 }
922
923 f->value.function.name =
924 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
925 }
926
927
928 void
929 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
930 {
931 gfc_resolve_minmax ("__max_%c%d", f, args);
932 }
933
934
935 void
936 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
937 gfc_expr * mask)
938 {
939 const char *name;
940
941 f->ts.type = BT_INTEGER;
942 f->ts.kind = gfc_default_integer_kind;
943
944 if (dim == NULL)
945 f->rank = 1;
946 else
947 {
948 f->rank = array->rank - 1;
949 gfc_resolve_dim_arg (dim);
950 }
951
952 name = mask ? "mmaxloc" : "maxloc";
953 f->value.function.name =
954 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
955 gfc_type_letter (array->ts.type), array->ts.kind);
956 }
957
958
959 void
960 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
961 gfc_expr * mask)
962 {
963 f->ts = array->ts;
964
965 if (dim != NULL)
966 {
967 f->rank = array->rank - 1;
968 gfc_resolve_dim_arg (dim);
969 }
970
971 f->value.function.name =
972 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
973 gfc_type_letter (array->ts.type), array->ts.kind);
974 }
975
976
977 void
978 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
979 gfc_expr * fsource ATTRIBUTE_UNUSED,
980 gfc_expr * mask ATTRIBUTE_UNUSED)
981 {
982 f->ts = tsource->ts;
983 f->value.function.name =
984 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
985 tsource->ts.kind);
986 }
987
988
989 void
990 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
991 {
992 gfc_resolve_minmax ("__min_%c%d", f, args);
993 }
994
995
996 void
997 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
998 gfc_expr * mask)
999 {
1000 const char *name;
1001
1002 f->ts.type = BT_INTEGER;
1003 f->ts.kind = gfc_default_integer_kind;
1004
1005 if (dim == NULL)
1006 f->rank = 1;
1007 else
1008 {
1009 f->rank = array->rank - 1;
1010 gfc_resolve_dim_arg (dim);
1011 }
1012
1013 name = mask ? "mminloc" : "minloc";
1014 f->value.function.name =
1015 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1016 gfc_type_letter (array->ts.type), array->ts.kind);
1017 }
1018
1019
1020 void
1021 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1022 gfc_expr * mask)
1023 {
1024 f->ts = array->ts;
1025
1026 if (dim != NULL)
1027 {
1028 f->rank = array->rank - 1;
1029 gfc_resolve_dim_arg (dim);
1030 }
1031
1032 f->value.function.name =
1033 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1034 gfc_type_letter (array->ts.type), array->ts.kind);
1035 }
1036
1037
1038 void
1039 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1040 gfc_expr * p ATTRIBUTE_UNUSED)
1041 {
1042 f->ts = a->ts;
1043 f->value.function.name =
1044 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1045 }
1046
1047
1048 void
1049 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1050 gfc_expr * p ATTRIBUTE_UNUSED)
1051 {
1052 f->ts = a->ts;
1053 f->value.function.name =
1054 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1055 a->ts.kind);
1056 }
1057
1058 void
1059 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1060 {
1061 f->ts = a->ts;
1062 f->value.function.name =
1063 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1064 a->ts.kind);
1065 }
1066
1067 void
1068 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1069 {
1070 f->ts.type = BT_INTEGER;
1071 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1072 : mpz_get_si (kind->value.integer);
1073
1074 f->value.function.name =
1075 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1076 }
1077
1078
1079 void
1080 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1081 {
1082 f->ts = i->ts;
1083 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1084 }
1085
1086
1087 void
1088 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1089 gfc_expr * vector ATTRIBUTE_UNUSED)
1090 {
1091 f->ts = array->ts;
1092 f->rank = 1;
1093
1094 if (mask->rank != 0)
1095 f->value.function.name = (array->ts.type == BT_CHARACTER
1096 ? PREFIX("pack_char")
1097 : PREFIX("pack"));
1098 else
1099 {
1100 /* We convert mask to default logical only in the scalar case.
1101 In the array case we can simply read the array as if it were
1102 of type default logical. */
1103 if (mask->ts.kind != gfc_default_logical_kind)
1104 {
1105 gfc_typespec ts;
1106
1107 ts.type = BT_LOGICAL;
1108 ts.kind = gfc_default_logical_kind;
1109 gfc_convert_type (mask, &ts, 2);
1110 }
1111
1112 f->value.function.name = (array->ts.type == BT_CHARACTER
1113 ? PREFIX("pack_s_char")
1114 : PREFIX("pack_s"));
1115 }
1116 }
1117
1118
1119 void
1120 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1121 gfc_expr * mask)
1122 {
1123 f->ts = array->ts;
1124
1125 if (dim != NULL)
1126 {
1127 f->rank = array->rank - 1;
1128 gfc_resolve_dim_arg (dim);
1129 }
1130
1131 f->value.function.name =
1132 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1133 gfc_type_letter (array->ts.type), array->ts.kind);
1134 }
1135
1136
1137 void
1138 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1139 {
1140 f->ts.type = BT_REAL;
1141
1142 if (kind != NULL)
1143 f->ts.kind = mpz_get_si (kind->value.integer);
1144 else
1145 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1146 a->ts.kind : gfc_default_real_kind;
1147
1148 f->value.function.name =
1149 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1150 gfc_type_letter (a->ts.type), a->ts.kind);
1151 }
1152
1153
1154 void
1155 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1156 {
1157 f->ts.type = BT_REAL;
1158 f->ts.kind = a->ts.kind;
1159 f->value.function.name =
1160 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1161 gfc_type_letter (a->ts.type), a->ts.kind);
1162 }
1163
1164
1165 void
1166 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1167 gfc_expr * p2 ATTRIBUTE_UNUSED)
1168 {
1169 f->ts.type = BT_INTEGER;
1170 f->ts.kind = gfc_default_integer_kind;
1171 f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1172 }
1173
1174
1175 void
1176 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1177 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1178 {
1179 f->ts.type = BT_CHARACTER;
1180 f->ts.kind = string->ts.kind;
1181 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1182 }
1183
1184
1185 void
1186 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1187 gfc_expr * pad ATTRIBUTE_UNUSED,
1188 gfc_expr * order ATTRIBUTE_UNUSED)
1189 {
1190 mpz_t rank;
1191 int kind;
1192 int i;
1193
1194 f->ts = source->ts;
1195
1196 gfc_array_size (shape, &rank);
1197 f->rank = mpz_get_si (rank);
1198 mpz_clear (rank);
1199 switch (source->ts.type)
1200 {
1201 case BT_COMPLEX:
1202 kind = source->ts.kind * 2;
1203 break;
1204
1205 case BT_REAL:
1206 case BT_INTEGER:
1207 case BT_LOGICAL:
1208 kind = source->ts.kind;
1209 break;
1210
1211 default:
1212 kind = 0;
1213 break;
1214 }
1215
1216 switch (kind)
1217 {
1218 case 4:
1219 case 8:
1220 case 10:
1221 case 16:
1222 if (source->ts.type == BT_COMPLEX)
1223 f->value.function.name =
1224 gfc_get_string (PREFIX("reshape_%c%d"),
1225 gfc_type_letter (BT_COMPLEX), source->ts.kind);
1226 else
1227 f->value.function.name =
1228 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1229
1230 break;
1231
1232 default:
1233 f->value.function.name = (source->ts.type == BT_CHARACTER
1234 ? PREFIX("reshape_char")
1235 : PREFIX("reshape"));
1236 break;
1237 }
1238
1239 /* TODO: Make this work with a constant ORDER parameter. */
1240 if (shape->expr_type == EXPR_ARRAY
1241 && gfc_is_constant_expr (shape)
1242 && order == NULL)
1243 {
1244 gfc_constructor *c;
1245 f->shape = gfc_get_shape (f->rank);
1246 c = shape->value.constructor;
1247 for (i = 0; i < f->rank; i++)
1248 {
1249 mpz_init_set (f->shape[i], c->expr->value.integer);
1250 c = c->next;
1251 }
1252 }
1253
1254 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1255 so many runtime variations. */
1256 if (shape->ts.kind != gfc_index_integer_kind)
1257 {
1258 gfc_typespec ts = shape->ts;
1259 ts.kind = gfc_index_integer_kind;
1260 gfc_convert_type_warn (shape, &ts, 2, 0);
1261 }
1262 if (order && order->ts.kind != gfc_index_integer_kind)
1263 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1264 }
1265
1266
1267 void
1268 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1269 {
1270 f->ts = x->ts;
1271 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1272 }
1273
1274
1275 void
1276 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1277 {
1278 f->ts = x->ts;
1279
1280 /* The implementation calls scalbn which takes an int as the
1281 second argument. */
1282 if (i->ts.kind != gfc_c_int_kind)
1283 {
1284 gfc_typespec ts;
1285
1286 ts.type = BT_INTEGER;
1287 ts.kind = gfc_default_integer_kind;
1288
1289 gfc_convert_type_warn (i, &ts, 2, 0);
1290 }
1291
1292 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1293 }
1294
1295
1296 void
1297 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1298 gfc_expr * set ATTRIBUTE_UNUSED,
1299 gfc_expr * back ATTRIBUTE_UNUSED)
1300 {
1301 f->ts.type = BT_INTEGER;
1302 f->ts.kind = gfc_default_integer_kind;
1303 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1304 }
1305
1306
1307 void
1308 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1309 {
1310 f->ts = x->ts;
1311
1312 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1313 convert type so we don't have to implement all possible
1314 permutations. */
1315 if (i->ts.kind != 4)
1316 {
1317 gfc_typespec ts;
1318
1319 ts.type = BT_INTEGER;
1320 ts.kind = gfc_default_integer_kind;
1321
1322 gfc_convert_type_warn (i, &ts, 2, 0);
1323 }
1324
1325 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1326 }
1327
1328
1329 void
1330 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1331 {
1332 f->ts.type = BT_INTEGER;
1333 f->ts.kind = gfc_default_integer_kind;
1334 f->rank = 1;
1335 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1336 f->shape = gfc_get_shape (1);
1337 mpz_init_set_ui (f->shape[0], array->rank);
1338 }
1339
1340
1341 void
1342 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1343 {
1344 f->ts = a->ts;
1345 f->value.function.name =
1346 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1347 }
1348
1349
1350 void
1351 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1352 {
1353 f->ts = x->ts;
1354 f->value.function.name =
1355 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1356 }
1357
1358
1359 void
1360 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1361 {
1362 f->ts = x->ts;
1363 f->value.function.name =
1364 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1365 }
1366
1367
1368 void
1369 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1370 {
1371 f->ts = x->ts;
1372 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1373 }
1374
1375
1376 void
1377 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1378 gfc_expr * dim,
1379 gfc_expr * ncopies)
1380 {
1381 f->ts = source->ts;
1382 f->rank = source->rank + 1;
1383 f->value.function.name = (source->ts.type == BT_CHARACTER
1384 ? PREFIX("spread_char")
1385 : PREFIX("spread"));
1386
1387 gfc_resolve_dim_arg (dim);
1388 gfc_resolve_index (ncopies, 1);
1389 }
1390
1391
1392 void
1393 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1394 {
1395 f->ts = x->ts;
1396 f->value.function.name =
1397 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1398 }
1399
1400
1401 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1402
1403 void
1404 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1405 gfc_expr * a ATTRIBUTE_UNUSED)
1406 {
1407 f->ts.type = BT_INTEGER;
1408 f->ts.kind = gfc_default_integer_kind;
1409 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1410 }
1411
1412
1413 void
1414 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1415 {
1416 f->ts.type = BT_INTEGER;
1417 f->ts.kind = gfc_default_integer_kind;
1418 if (n->ts.kind != f->ts.kind)
1419 gfc_convert_type (n, &f->ts, 2);
1420
1421 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1422 }
1423
1424
1425 void
1426 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1427 gfc_expr * mask)
1428 {
1429 f->ts = array->ts;
1430
1431 if (dim != NULL)
1432 {
1433 f->rank = array->rank - 1;
1434 gfc_resolve_dim_arg (dim);
1435 }
1436
1437 f->value.function.name =
1438 gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1439 gfc_type_letter (array->ts.type), array->ts.kind);
1440 }
1441
1442
1443 void
1444 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1445 gfc_expr * p2 ATTRIBUTE_UNUSED)
1446 {
1447 f->ts.type = BT_INTEGER;
1448 f->ts.kind = gfc_default_integer_kind;
1449 f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1450 }
1451
1452
1453 /* Resolve the g77 compatibility function SYSTEM. */
1454
1455 void
1456 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1457 {
1458 f->ts.type = BT_INTEGER;
1459 f->ts.kind = 4;
1460 f->value.function.name = gfc_get_string (PREFIX("system"));
1461 }
1462
1463
1464 void
1465 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1466 {
1467 f->ts = x->ts;
1468 f->value.function.name =
1469 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1470 }
1471
1472
1473 void
1474 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1475 {
1476 f->ts = x->ts;
1477 f->value.function.name =
1478 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1479 }
1480
1481
1482 void
1483 gfc_resolve_time (gfc_expr * f)
1484 {
1485 f->ts.type = BT_INTEGER;
1486 f->ts.kind = 4;
1487 f->value.function.name = gfc_get_string (PREFIX("time_func"));
1488 }
1489
1490
1491 void
1492 gfc_resolve_time8 (gfc_expr * f)
1493 {
1494 f->ts.type = BT_INTEGER;
1495 f->ts.kind = 8;
1496 f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1497 }
1498
1499
1500 void
1501 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1502 gfc_expr * mold, gfc_expr * size)
1503 {
1504 /* TODO: Make this do something meaningful. */
1505 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1506
1507 f->ts = mold->ts;
1508
1509 if (size == NULL && mold->rank == 0)
1510 {
1511 f->rank = 0;
1512 f->value.function.name = transfer0;
1513 }
1514 else
1515 {
1516 f->rank = 1;
1517 f->value.function.name = transfer1;
1518 }
1519 }
1520
1521
1522 void
1523 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1524 {
1525 int kind;
1526
1527 f->ts = matrix->ts;
1528 f->rank = 2;
1529 if (matrix->shape)
1530 {
1531 f->shape = gfc_get_shape (2);
1532 mpz_init_set (f->shape[0], matrix->shape[1]);
1533 mpz_init_set (f->shape[1], matrix->shape[0]);
1534 }
1535
1536 kind = matrix->ts.kind;
1537
1538 switch (kind)
1539 {
1540 case 4:
1541 case 8:
1542 case 10:
1543 case 16:
1544 switch (matrix->ts.type)
1545 {
1546 case BT_COMPLEX:
1547 f->value.function.name =
1548 gfc_get_string (PREFIX("transpose_c%d"), kind);
1549 break;
1550
1551 case BT_INTEGER:
1552 case BT_REAL:
1553 case BT_LOGICAL:
1554 /* Use the integer routines for real and logical cases. This
1555 assumes they all have the same alignment requirements. */
1556 f->value.function.name =
1557 gfc_get_string (PREFIX("transpose_i%d"), kind);
1558 break;
1559
1560 default:
1561 f->value.function.name = PREFIX("transpose");
1562 break;
1563 }
1564 break;
1565
1566 default:
1567 f->value.function.name = (matrix->ts.type == BT_CHARACTER
1568 ? PREFIX("transpose_char")
1569 : PREFIX("transpose"));
1570 break;
1571 }
1572 }
1573
1574
1575 void
1576 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1577 {
1578 f->ts.type = BT_CHARACTER;
1579 f->ts.kind = string->ts.kind;
1580 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1581 }
1582
1583
1584 void
1585 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1586 gfc_expr * dim)
1587 {
1588 static char ubound[] = "__ubound";
1589
1590 f->ts.type = BT_INTEGER;
1591 f->ts.kind = gfc_default_integer_kind;
1592
1593 if (dim == NULL)
1594 {
1595 f->rank = 1;
1596 f->shape = gfc_get_shape (1);
1597 mpz_init_set_ui (f->shape[0], array->rank);
1598 }
1599
1600 f->value.function.name = ubound;
1601 }
1602
1603
1604 /* Resolve the g77 compatibility function UMASK. */
1605
1606 void
1607 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1608 {
1609 f->ts.type = BT_INTEGER;
1610 f->ts.kind = n->ts.kind;
1611 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1612 }
1613
1614
1615 /* Resolve the g77 compatibility function UNLINK. */
1616
1617 void
1618 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1619 {
1620 f->ts.type = BT_INTEGER;
1621 f->ts.kind = 4;
1622 f->value.function.name = gfc_get_string (PREFIX("unlink"));
1623 }
1624
1625 void
1626 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1627 gfc_expr * field ATTRIBUTE_UNUSED)
1628 {
1629 f->ts = vector->ts;
1630 f->rank = mask->rank;
1631
1632 f->value.function.name =
1633 gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1634 vector->ts.type == BT_CHARACTER ? "_char" : "");
1635 }
1636
1637
1638 void
1639 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1640 gfc_expr * set ATTRIBUTE_UNUSED,
1641 gfc_expr * back ATTRIBUTE_UNUSED)
1642 {
1643 f->ts.type = BT_INTEGER;
1644 f->ts.kind = gfc_default_integer_kind;
1645 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1646 }
1647
1648
1649 /* Intrinsic subroutine resolution. */
1650
1651 void
1652 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1653 {
1654 const char *name;
1655
1656 name = gfc_get_string (PREFIX("cpu_time_%d"),
1657 c->ext.actual->expr->ts.kind);
1658 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1659 }
1660
1661
1662 void
1663 gfc_resolve_mvbits (gfc_code * c)
1664 {
1665 const char *name;
1666 int kind;
1667
1668 kind = c->ext.actual->expr->ts.kind;
1669 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1670
1671 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1672 }
1673
1674
1675 void
1676 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1677 {
1678 const char *name;
1679 int kind;
1680
1681 kind = c->ext.actual->expr->ts.kind;
1682 if (c->ext.actual->expr->rank == 0)
1683 name = gfc_get_string (PREFIX("random_r%d"), kind);
1684 else
1685 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1686
1687 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1688 }
1689
1690
1691 void
1692 gfc_resolve_rename_sub (gfc_code * c)
1693 {
1694 const char *name;
1695 int kind;
1696
1697 if (c->ext.actual->next->next->expr != NULL)
1698 kind = c->ext.actual->next->next->expr->ts.kind;
1699 else
1700 kind = gfc_default_integer_kind;
1701
1702 name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1703 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1704 }
1705
1706
1707 void
1708 gfc_resolve_kill_sub (gfc_code * c)
1709 {
1710 const char *name;
1711 int kind;
1712
1713 if (c->ext.actual->next->next->expr != NULL)
1714 kind = c->ext.actual->next->next->expr->ts.kind;
1715 else
1716 kind = gfc_default_integer_kind;
1717
1718 name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1719 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1720 }
1721
1722
1723 void
1724 gfc_resolve_link_sub (gfc_code * c)
1725 {
1726 const char *name;
1727 int kind;
1728
1729 if (c->ext.actual->next->next->expr != NULL)
1730 kind = c->ext.actual->next->next->expr->ts.kind;
1731 else
1732 kind = gfc_default_integer_kind;
1733
1734 name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1735 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1736 }
1737
1738
1739 void
1740 gfc_resolve_symlnk_sub (gfc_code * c)
1741 {
1742 const char *name;
1743 int kind;
1744
1745 if (c->ext.actual->next->next->expr != NULL)
1746 kind = c->ext.actual->next->next->expr->ts.kind;
1747 else
1748 kind = gfc_default_integer_kind;
1749
1750 name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1751 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1752 }
1753
1754
1755 /* G77 compatibility subroutines etime() and dtime(). */
1756
1757 void
1758 gfc_resolve_etime_sub (gfc_code * c)
1759 {
1760 const char *name;
1761
1762 name = gfc_get_string (PREFIX("etime_sub"));
1763 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1764 }
1765
1766
1767 /* G77 compatibility subroutine second(). */
1768
1769 void
1770 gfc_resolve_second_sub (gfc_code * c)
1771 {
1772 const char *name;
1773
1774 name = gfc_get_string (PREFIX("second_sub"));
1775 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1776 }
1777
1778
1779 void
1780 gfc_resolve_sleep_sub (gfc_code * c)
1781 {
1782 const char *name;
1783 int kind;
1784
1785 if (c->ext.actual->expr != NULL)
1786 kind = c->ext.actual->expr->ts.kind;
1787 else
1788 kind = gfc_default_integer_kind;
1789
1790 name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1791 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1792 }
1793
1794
1795 /* G77 compatibility function srand(). */
1796
1797 void
1798 gfc_resolve_srand (gfc_code * c)
1799 {
1800 const char *name;
1801 name = gfc_get_string (PREFIX("srand"));
1802 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 }
1804
1805
1806 /* Resolve the getarg intrinsic subroutine. */
1807
1808 void
1809 gfc_resolve_getarg (gfc_code * c)
1810 {
1811 const char *name;
1812 int kind;
1813
1814 kind = gfc_default_integer_kind;
1815 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1816 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1817 }
1818
1819 /* Resolve the getcwd intrinsic subroutine. */
1820
1821 void
1822 gfc_resolve_getcwd_sub (gfc_code * c)
1823 {
1824 const char *name;
1825 int kind;
1826
1827 if (c->ext.actual->next->expr != NULL)
1828 kind = c->ext.actual->next->expr->ts.kind;
1829 else
1830 kind = gfc_default_integer_kind;
1831
1832 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1833 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1834 }
1835
1836
1837 /* Resolve the get_command intrinsic subroutine. */
1838
1839 void
1840 gfc_resolve_get_command (gfc_code * c)
1841 {
1842 const char *name;
1843 int kind;
1844
1845 kind = gfc_default_integer_kind;
1846 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1847 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1848 }
1849
1850
1851 /* Resolve the get_command_argument intrinsic subroutine. */
1852
1853 void
1854 gfc_resolve_get_command_argument (gfc_code * c)
1855 {
1856 const char *name;
1857 int kind;
1858
1859 kind = gfc_default_integer_kind;
1860 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1861 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1862 }
1863
1864 /* Resolve the get_environment_variable intrinsic subroutine. */
1865
1866 void
1867 gfc_resolve_get_environment_variable (gfc_code * code)
1868 {
1869 const char *name;
1870 int kind;
1871
1872 kind = gfc_default_integer_kind;
1873 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1874 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1875 }
1876
1877 /* Resolve the SYSTEM intrinsic subroutine. */
1878
1879 void
1880 gfc_resolve_system_sub (gfc_code * c)
1881 {
1882 const char *name;
1883
1884 name = gfc_get_string (PREFIX("system_sub"));
1885 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1886 }
1887
1888 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1889
1890 void
1891 gfc_resolve_system_clock (gfc_code * c)
1892 {
1893 const char *name;
1894 int kind;
1895
1896 if (c->ext.actual->expr != NULL)
1897 kind = c->ext.actual->expr->ts.kind;
1898 else if (c->ext.actual->next->expr != NULL)
1899 kind = c->ext.actual->next->expr->ts.kind;
1900 else if (c->ext.actual->next->next->expr != NULL)
1901 kind = c->ext.actual->next->next->expr->ts.kind;
1902 else
1903 kind = gfc_default_integer_kind;
1904
1905 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1906 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1907 }
1908
1909 /* Resolve the EXIT intrinsic subroutine. */
1910
1911 void
1912 gfc_resolve_exit (gfc_code * c)
1913 {
1914 const char *name;
1915 int kind;
1916
1917 if (c->ext.actual->expr != NULL)
1918 kind = c->ext.actual->expr->ts.kind;
1919 else
1920 kind = gfc_default_integer_kind;
1921
1922 name = gfc_get_string (PREFIX("exit_i%d"), kind);
1923 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1924 }
1925
1926 /* Resolve the FLUSH intrinsic subroutine. */
1927
1928 void
1929 gfc_resolve_flush (gfc_code * c)
1930 {
1931 const char *name;
1932 gfc_typespec ts;
1933 gfc_expr *n;
1934
1935 ts.type = BT_INTEGER;
1936 ts.kind = gfc_default_integer_kind;
1937 n = c->ext.actual->expr;
1938 if (n != NULL
1939 && n->ts.kind != ts.kind)
1940 gfc_convert_type (n, &ts, 2);
1941
1942 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1943 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1944 }
1945
1946
1947 void
1948 gfc_resolve_gerror (gfc_code * c)
1949 {
1950 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
1951 }
1952
1953
1954 void
1955 gfc_resolve_getlog (gfc_code * c)
1956 {
1957 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
1958 }
1959
1960
1961 void
1962 gfc_resolve_hostnm_sub (gfc_code * c)
1963 {
1964 const char *name;
1965 int kind;
1966
1967 if (c->ext.actual->next->expr != NULL)
1968 kind = c->ext.actual->next->expr->ts.kind;
1969 else
1970 kind = gfc_default_integer_kind;
1971
1972 name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
1973 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1974 }
1975
1976
1977 void
1978 gfc_resolve_perror (gfc_code * c)
1979 {
1980 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
1981 }
1982
1983 /* Resolve the STAT and FSTAT intrinsic subroutines. */
1984
1985 void
1986 gfc_resolve_stat_sub (gfc_code * c)
1987 {
1988 const char *name;
1989
1990 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1991 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1992 }
1993
1994
1995 void
1996 gfc_resolve_fstat_sub (gfc_code * c)
1997 {
1998 const char *name;
1999 gfc_expr *u;
2000 gfc_typespec *ts;
2001
2002 u = c->ext.actual->expr;
2003 ts = &c->ext.actual->next->expr->ts;
2004 if (u->ts.kind != ts->kind)
2005 gfc_convert_type (u, ts, 2);
2006 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2007 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2008 }
2009
2010
2011 void
2012 gfc_resolve_ttynam_sub (gfc_code * c)
2013 {
2014 gfc_typespec ts;
2015
2016 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2017 {
2018 ts.type = BT_INTEGER;
2019 ts.kind = gfc_c_int_kind;
2020 ts.derived = NULL;
2021 ts.cl = NULL;
2022 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2023 }
2024
2025 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2026 }
2027
2028
2029 /* Resolve the UMASK intrinsic subroutine. */
2030
2031 void
2032 gfc_resolve_umask_sub (gfc_code * c)
2033 {
2034 const char *name;
2035 int kind;
2036
2037 if (c->ext.actual->next->expr != NULL)
2038 kind = c->ext.actual->next->expr->ts.kind;
2039 else
2040 kind = gfc_default_integer_kind;
2041
2042 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2043 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2044 }
2045
2046 /* Resolve the UNLINK intrinsic subroutine. */
2047
2048 void
2049 gfc_resolve_unlink_sub (gfc_code * c)
2050 {
2051 const char *name;
2052 int kind;
2053
2054 if (c->ext.actual->next->expr != NULL)
2055 kind = c->ext.actual->next->expr->ts.kind;
2056 else
2057 kind = gfc_default_integer_kind;
2058
2059 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2060 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2061 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org