OSDN Git Service

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