OSDN Git Service

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