OSDN Git Service

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