OSDN Git Service

f961c776e211ea8fe9cc7f6141838a962cb2d181
[pf3gnuchains/gcc-fork.git] / gcc / fortran / iresolve.c
1 /* Intrinsic function resolution.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
3    Inc.
4    Contributed by Andy Vaught & Katherine Holcomb
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23
24 /* Assign name and types to intrinsic procedures.  For functions, the
25    first argument to a resolution function is an expression pointer to
26    the original function node and the rest are pointers to the
27    arguments of the function call.  For subroutines, a pointer to the
28    code node is passed.  The result type and library subroutine name
29    are generally set according to the function arguments.  */
30
31 #include "config.h"
32 #include "system.h"
33 #include "coretypes.h"
34 #include "tree.h"
35 #include "gfortran.h"
36 #include "intrinsic.h"
37
38
39 /* Given printf-like arguments, return a stable version of the result string. 
40
41    We already have a working, optimized string hashing table in the form of
42    the identifier table.  Reusing this table is likely not to be wasted, 
43    since if the function name makes it to the gimple output of the frontend,
44    we'll have to create the identifier anyway.  */
45
46 const char *
47 gfc_get_string (const char *format, ...)
48 {
49   char temp_name[128];
50   va_list ap;
51   tree ident;
52
53   va_start (ap, format);
54   vsnprintf (temp_name, sizeof(temp_name), format, ap);
55   va_end (ap);
56   temp_name[sizeof(temp_name)-1] = 0;
57
58   ident = get_identifier (temp_name);
59   return IDENTIFIER_POINTER (ident);
60 }
61
62 /* 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   name = mask ? "mmaxloc" : "maxloc";
1097   f->value.function.name =
1098     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1099                     gfc_type_letter (array->ts.type), array->ts.kind);
1100 }
1101
1102
1103 void
1104 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1105                     gfc_expr * mask)
1106 {
1107   f->ts = array->ts;
1108
1109   if (dim != NULL)
1110     {
1111       f->rank = array->rank - 1;
1112       gfc_resolve_dim_arg (dim);
1113     }
1114
1115   f->value.function.name =
1116     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
1117                     gfc_type_letter (array->ts.type), array->ts.kind);
1118 }
1119
1120
1121 void
1122 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1123                    gfc_expr * fsource ATTRIBUTE_UNUSED,
1124                    gfc_expr * mask ATTRIBUTE_UNUSED)
1125 {
1126   if (tsource->ts.type == BT_CHARACTER)
1127     check_charlen_present (tsource);
1128
1129   f->ts = tsource->ts;
1130   f->value.function.name =
1131     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1132                     tsource->ts.kind);
1133 }
1134
1135
1136 void
1137 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1138 {
1139   gfc_resolve_minmax ("__min_%c%d", f, args);
1140 }
1141
1142
1143 void
1144 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1145                     gfc_expr * mask)
1146 {
1147   const char *name;
1148
1149   f->ts.type = BT_INTEGER;
1150   f->ts.kind = gfc_default_integer_kind;
1151
1152   if (dim == NULL)
1153     f->rank = 1;
1154   else
1155     {
1156       f->rank = array->rank - 1;
1157       gfc_resolve_dim_arg (dim);
1158     }
1159
1160   name = mask ? "mminloc" : "minloc";
1161   f->value.function.name =
1162     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1163                     gfc_type_letter (array->ts.type), array->ts.kind);
1164 }
1165
1166
1167 void
1168 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1169                     gfc_expr * mask)
1170 {
1171   f->ts = array->ts;
1172
1173   if (dim != NULL)
1174     {
1175       f->rank = array->rank - 1;
1176       gfc_resolve_dim_arg (dim);
1177     }
1178
1179   f->value.function.name =
1180     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1181                     gfc_type_letter (array->ts.type), array->ts.kind);
1182 }
1183
1184
1185 void
1186 gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1187 {
1188   f->ts.type = a->ts.type;
1189   if (p != NULL)
1190     f->ts.kind = gfc_kind_max (a,p);
1191   else
1192     f->ts.kind = a->ts.kind;
1193
1194   if (p != NULL && a->ts.kind != p->ts.kind)
1195     {
1196       if (a->ts.kind == gfc_kind_max (a,p))
1197         gfc_convert_type(p, &a->ts, 2);
1198       else
1199         gfc_convert_type(a, &p->ts, 2);
1200     }
1201
1202   f->value.function.name =
1203     gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1204 }
1205
1206
1207 void
1208 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1209 {
1210   f->ts.type = a->ts.type;
1211   if (p != NULL)
1212     f->ts.kind = gfc_kind_max (a,p);
1213   else
1214     f->ts.kind = a->ts.kind;
1215
1216   if (p != NULL && a->ts.kind != p->ts.kind)
1217     {
1218       if (a->ts.kind == gfc_kind_max (a,p))
1219         gfc_convert_type(p, &a->ts, 2);
1220       else
1221         gfc_convert_type(a, &p->ts, 2);
1222     }
1223
1224   f->value.function.name =
1225     gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1226                     f->ts.kind);
1227 }
1228
1229 void
1230 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1231 {
1232   f->ts = a->ts;
1233   f->value.function.name =
1234     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1235             a->ts.kind);
1236 }
1237
1238 void
1239 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1240 {
1241   f->ts.type = BT_INTEGER;
1242   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1243     : mpz_get_si (kind->value.integer);
1244
1245   f->value.function.name =
1246     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1247 }
1248
1249
1250 void
1251 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1252 {
1253   f->ts = i->ts;
1254   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1255 }
1256
1257
1258 void
1259 gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1260 {
1261   f->ts.type = i->ts.type;
1262   f->ts.kind = gfc_kind_max (i,j);
1263
1264   if (i->ts.kind != j->ts.kind)
1265     {
1266       if (i->ts.kind == gfc_kind_max (i,j))
1267         gfc_convert_type(j, &i->ts, 2);
1268       else
1269         gfc_convert_type(i, &j->ts, 2);
1270     }
1271
1272   f->value.function.name = gfc_get_string ("__or_%c%d",
1273                                            gfc_type_letter (i->ts.type),
1274                                            f->ts.kind);
1275 }
1276
1277
1278 void
1279 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1280                   gfc_expr * vector ATTRIBUTE_UNUSED)
1281 {
1282   f->ts = array->ts;
1283   f->rank = 1;
1284
1285   if (mask->rank != 0)
1286     f->value.function.name = (array->ts.type == BT_CHARACTER
1287                               ? PREFIX("pack_char")
1288                               : PREFIX("pack"));
1289   else
1290     {
1291       /* We convert mask to default logical only in the scalar case.
1292          In the array case we can simply read the array as if it were
1293          of type default logical.  */
1294       if (mask->ts.kind != gfc_default_logical_kind)
1295         {
1296           gfc_typespec ts;
1297
1298           ts.type = BT_LOGICAL;
1299           ts.kind = gfc_default_logical_kind;
1300           gfc_convert_type (mask, &ts, 2);
1301         }
1302
1303       f->value.function.name = (array->ts.type == BT_CHARACTER
1304                                 ? PREFIX("pack_s_char")
1305                                 : PREFIX("pack_s"));
1306     }
1307 }
1308
1309
1310 void
1311 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1312                      gfc_expr * mask)
1313 {
1314   f->ts = array->ts;
1315
1316   if (dim != NULL)
1317     {
1318       f->rank = array->rank - 1;
1319       gfc_resolve_dim_arg (dim);
1320     }
1321
1322   f->value.function.name =
1323     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1324                     gfc_type_letter (array->ts.type), array->ts.kind);
1325 }
1326
1327
1328 void
1329 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1330 {
1331   f->ts.type = BT_REAL;
1332
1333   if (kind != NULL)
1334     f->ts.kind = mpz_get_si (kind->value.integer);
1335   else
1336     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1337       a->ts.kind : gfc_default_real_kind;
1338
1339   f->value.function.name =
1340     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1341                     gfc_type_letter (a->ts.type), a->ts.kind);
1342 }
1343
1344
1345 void
1346 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1347 {
1348   f->ts.type = BT_REAL;
1349   f->ts.kind = a->ts.kind;
1350   f->value.function.name =
1351     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1352                     gfc_type_letter (a->ts.type), a->ts.kind);
1353 }
1354
1355
1356 void
1357 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1358                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1359 {
1360   f->ts.type = BT_INTEGER;
1361   f->ts.kind = gfc_default_integer_kind;
1362   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1363 }
1364
1365
1366 void
1367 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1368                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1369 {
1370   f->ts.type = BT_CHARACTER;
1371   f->ts.kind = string->ts.kind;
1372   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1373 }
1374
1375
1376 void
1377 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1378                      gfc_expr * pad ATTRIBUTE_UNUSED,
1379                      gfc_expr * order ATTRIBUTE_UNUSED)
1380 {
1381   mpz_t rank;
1382   int kind;
1383   int i;
1384
1385   f->ts = source->ts;
1386
1387   gfc_array_size (shape, &rank);
1388   f->rank = mpz_get_si (rank);
1389   mpz_clear (rank);
1390   switch (source->ts.type)
1391     {
1392     case BT_COMPLEX:
1393       kind = source->ts.kind * 2;
1394       break;
1395
1396     case BT_REAL:
1397     case BT_INTEGER:
1398     case BT_LOGICAL:
1399       kind = source->ts.kind;
1400       break;
1401
1402     default:
1403       kind = 0;
1404       break;
1405     }
1406
1407   switch (kind)
1408     {
1409     case 4:
1410     case 8:
1411     case 10:
1412     case 16:
1413       if (source->ts.type == BT_COMPLEX)
1414         f->value.function.name =
1415           gfc_get_string (PREFIX("reshape_%c%d"),
1416                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1417       else
1418         f->value.function.name =
1419           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1420
1421       break;
1422
1423     default:
1424       f->value.function.name = (source->ts.type == BT_CHARACTER
1425                                 ? PREFIX("reshape_char")
1426                                 : PREFIX("reshape"));
1427       break;
1428     }
1429
1430   /* TODO: Make this work with a constant ORDER parameter.  */
1431   if (shape->expr_type == EXPR_ARRAY
1432       && gfc_is_constant_expr (shape)
1433       && order == NULL)
1434     {
1435       gfc_constructor *c;
1436       f->shape = gfc_get_shape (f->rank);
1437       c = shape->value.constructor;
1438       for (i = 0; i < f->rank; i++)
1439         {
1440           mpz_init_set (f->shape[i], c->expr->value.integer);
1441           c = c->next;
1442         }
1443     }
1444
1445   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1446      so many runtime variations.  */
1447   if (shape->ts.kind != gfc_index_integer_kind)
1448     {
1449       gfc_typespec ts = shape->ts;
1450       ts.kind = gfc_index_integer_kind;
1451       gfc_convert_type_warn (shape, &ts, 2, 0);
1452     }
1453   if (order && order->ts.kind != gfc_index_integer_kind)
1454     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1455 }
1456
1457
1458 void
1459 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1460 {
1461   f->ts = x->ts;
1462   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1463 }
1464
1465
1466 void
1467 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1468 {
1469   f->ts = x->ts;
1470
1471   /* The implementation calls scalbn which takes an int as the
1472      second argument.  */
1473   if (i->ts.kind != gfc_c_int_kind)
1474     {
1475       gfc_typespec ts;
1476
1477       ts.type = BT_INTEGER;
1478       ts.kind = gfc_default_integer_kind;
1479
1480       gfc_convert_type_warn (i, &ts, 2, 0);
1481     }
1482
1483   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1484 }
1485
1486
1487 void
1488 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1489                   gfc_expr * set ATTRIBUTE_UNUSED,
1490                   gfc_expr * back ATTRIBUTE_UNUSED)
1491 {
1492   f->ts.type = BT_INTEGER;
1493   f->ts.kind = gfc_default_integer_kind;
1494   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1495 }
1496
1497
1498 void
1499 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1500 {
1501   t1->ts = t0->ts;
1502   t1->value.function.name =
1503     gfc_get_string (PREFIX("secnds"));
1504 }
1505
1506
1507 void
1508 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1509 {
1510   f->ts = x->ts;
1511
1512   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1513      convert type so we don't have to implement all possible
1514      permutations.  */
1515   if (i->ts.kind != 4)
1516     {
1517       gfc_typespec ts;
1518
1519       ts.type = BT_INTEGER;
1520       ts.kind = gfc_default_integer_kind;
1521
1522       gfc_convert_type_warn (i, &ts, 2, 0);
1523     }
1524
1525   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1526 }
1527
1528
1529 void
1530 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1531 {
1532   f->ts.type = BT_INTEGER;
1533   f->ts.kind = gfc_default_integer_kind;
1534   f->rank = 1;
1535   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1536   f->shape = gfc_get_shape (1);
1537   mpz_init_set_ui (f->shape[0], array->rank);
1538 }
1539
1540
1541 void
1542 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1543 {
1544   f->ts = a->ts;
1545   f->value.function.name =
1546     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1547 }
1548
1549
1550 void
1551 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1552 {
1553   f->ts.type = BT_INTEGER;
1554   f->ts.kind = gfc_c_int_kind;
1555
1556   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1557   if (handler->ts.type == BT_INTEGER)
1558     {
1559       if (handler->ts.kind != gfc_c_int_kind)
1560         gfc_convert_type (handler, &f->ts, 2);
1561       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1562     }
1563   else
1564     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1565
1566   if (number->ts.kind != gfc_c_int_kind)
1567     gfc_convert_type (number, &f->ts, 2);
1568 }
1569
1570
1571 void
1572 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1573 {
1574   f->ts = x->ts;
1575   f->value.function.name =
1576     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1577 }
1578
1579
1580 void
1581 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1582 {
1583   f->ts = x->ts;
1584   f->value.function.name =
1585     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1586 }
1587
1588
1589 void
1590 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1591 {
1592   f->ts = x->ts;
1593   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1594 }
1595
1596
1597 void
1598 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1599                     gfc_expr * dim,
1600                     gfc_expr * ncopies)
1601 {
1602   if (source->ts.type == BT_CHARACTER)
1603     check_charlen_present (source);
1604
1605   f->ts = source->ts;
1606   f->rank = source->rank + 1;
1607   if (source->rank == 0)
1608     f->value.function.name = (source->ts.type == BT_CHARACTER
1609                               ? PREFIX("spread_char_scalar")
1610                               : PREFIX("spread_scalar"));
1611   else
1612     f->value.function.name = (source->ts.type == BT_CHARACTER
1613                               ? PREFIX("spread_char")
1614                               : PREFIX("spread"));
1615
1616   gfc_resolve_dim_arg (dim);
1617   gfc_resolve_index (ncopies, 1);
1618 }
1619
1620
1621 void
1622 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1623 {
1624   f->ts = x->ts;
1625   f->value.function.name =
1626     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1627 }
1628
1629
1630 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1631
1632 void
1633 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1634                   gfc_expr * a ATTRIBUTE_UNUSED)
1635 {
1636   f->ts.type = BT_INTEGER;
1637   f->ts.kind = gfc_default_integer_kind;
1638   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1639 }
1640
1641
1642 void
1643 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1644 {
1645   f->ts.type = BT_INTEGER;
1646   f->ts.kind = gfc_default_integer_kind;
1647   if (n->ts.kind != f->ts.kind)
1648     gfc_convert_type (n, &f->ts, 2);
1649
1650   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1651 }
1652
1653
1654 void
1655 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1656 {
1657   gfc_typespec ts;
1658
1659   f->ts.type = BT_INTEGER;
1660   f->ts.kind = gfc_c_int_kind;
1661   if (u->ts.kind != gfc_c_int_kind)
1662     {
1663       ts.type = BT_INTEGER;
1664       ts.kind = gfc_c_int_kind;
1665       ts.derived = NULL;
1666       ts.cl = NULL;
1667       gfc_convert_type (u, &ts, 2);
1668     }
1669
1670   f->value.function.name = gfc_get_string (PREFIX("fgetc"));
1671 }
1672
1673
1674 void
1675 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1676 {
1677   f->ts.type = BT_INTEGER;
1678   f->ts.kind = gfc_c_int_kind;
1679   f->value.function.name = gfc_get_string (PREFIX("fget"));
1680 }
1681
1682
1683 void
1684 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1685 {
1686   gfc_typespec ts;
1687
1688   f->ts.type = BT_INTEGER;
1689   f->ts.kind = gfc_c_int_kind;
1690   if (u->ts.kind != gfc_c_int_kind)
1691     {
1692       ts.type = BT_INTEGER;
1693       ts.kind = gfc_c_int_kind;
1694       ts.derived = NULL;
1695       ts.cl = NULL;
1696       gfc_convert_type (u, &ts, 2);
1697     }
1698
1699   f->value.function.name = gfc_get_string (PREFIX("fputc"));
1700 }
1701
1702
1703 void
1704 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1705 {
1706   f->ts.type = BT_INTEGER;
1707   f->ts.kind = gfc_c_int_kind;
1708   f->value.function.name = gfc_get_string (PREFIX("fput"));
1709 }
1710
1711
1712 void
1713 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
1714 {
1715   gfc_typespec ts;
1716
1717   f->ts.type = BT_INTEGER;
1718   f->ts.kind = gfc_index_integer_kind;
1719   if (u->ts.kind != gfc_c_int_kind)
1720     {
1721       ts.type = BT_INTEGER;
1722       ts.kind = gfc_c_int_kind;
1723       ts.derived = NULL;
1724       ts.cl = NULL;
1725       gfc_convert_type (u, &ts, 2);
1726     }
1727
1728   f->value.function.name = gfc_get_string (PREFIX("ftell"));
1729 }
1730
1731
1732 void
1733 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1734                  gfc_expr * mask)
1735 {
1736   f->ts = array->ts;
1737
1738   if (dim != NULL)
1739     {
1740       f->rank = array->rank - 1;
1741       gfc_resolve_dim_arg (dim);
1742     }
1743
1744   f->value.function.name =
1745     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1746                     gfc_type_letter (array->ts.type), array->ts.kind);
1747 }
1748
1749
1750 void
1751 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1752                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1753 {
1754   f->ts.type = BT_INTEGER;
1755   f->ts.kind = gfc_default_integer_kind;
1756   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1757 }
1758
1759
1760 /* Resolve the g77 compatibility function SYSTEM.  */
1761
1762 void
1763 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1764 {
1765   f->ts.type = BT_INTEGER;
1766   f->ts.kind = 4;
1767   f->value.function.name = gfc_get_string (PREFIX("system"));
1768 }
1769
1770
1771 void
1772 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1773 {
1774   f->ts = x->ts;
1775   f->value.function.name =
1776     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1777 }
1778
1779
1780 void
1781 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1782 {
1783   f->ts = x->ts;
1784   f->value.function.name =
1785     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1786 }
1787
1788
1789 void
1790 gfc_resolve_time (gfc_expr * f)
1791 {
1792   f->ts.type = BT_INTEGER;
1793   f->ts.kind = 4;
1794   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1795 }
1796
1797
1798 void
1799 gfc_resolve_time8 (gfc_expr * f)
1800 {
1801   f->ts.type = BT_INTEGER;
1802   f->ts.kind = 8;
1803   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1804 }
1805
1806
1807 void
1808 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1809                       gfc_expr * mold, gfc_expr * size)
1810 {
1811   /* TODO: Make this do something meaningful.  */
1812   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1813
1814   f->ts = mold->ts;
1815
1816   if (size == NULL && mold->rank == 0)
1817     {
1818       f->rank = 0;
1819       f->value.function.name = transfer0;
1820     }
1821   else
1822     {
1823       f->rank = 1;
1824       f->value.function.name = transfer1;
1825     }
1826 }
1827
1828
1829 void
1830 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1831 {
1832   int kind;
1833
1834   f->ts = matrix->ts;
1835   f->rank = 2;
1836   if (matrix->shape)
1837     {
1838       f->shape = gfc_get_shape (2);
1839       mpz_init_set (f->shape[0], matrix->shape[1]);
1840       mpz_init_set (f->shape[1], matrix->shape[0]);
1841     }
1842
1843   kind = matrix->ts.kind;
1844
1845   switch (kind)
1846     {
1847     case 4:
1848     case 8:
1849     case 10:
1850     case 16:
1851       switch (matrix->ts.type)
1852         {
1853         case BT_COMPLEX:
1854           f->value.function.name =
1855             gfc_get_string (PREFIX("transpose_c%d"), kind);
1856           break;
1857
1858         case BT_INTEGER:
1859         case BT_REAL:
1860         case BT_LOGICAL:
1861           /* Use the integer routines for real and logical cases.  This
1862              assumes they all have the same alignment requirements.  */
1863           f->value.function.name =
1864             gfc_get_string (PREFIX("transpose_i%d"), kind);
1865           break;
1866
1867         default:
1868           f->value.function.name = PREFIX("transpose");
1869           break;
1870         }
1871       break;
1872
1873     default:
1874       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1875                                 ? PREFIX("transpose_char")
1876                                 : PREFIX("transpose"));
1877       break;
1878     }
1879 }
1880
1881
1882 void
1883 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1884 {
1885   f->ts.type = BT_CHARACTER;
1886   f->ts.kind = string->ts.kind;
1887   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1888 }
1889
1890
1891 void
1892 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1893                     gfc_expr * dim)
1894 {
1895   static char ubound[] = "__ubound";
1896
1897   f->ts.type = BT_INTEGER;
1898   f->ts.kind = gfc_default_integer_kind;
1899
1900   if (dim == NULL)
1901     {
1902       f->rank = 1;
1903       f->shape = gfc_get_shape (1);
1904       mpz_init_set_ui (f->shape[0], array->rank);
1905     }
1906
1907   f->value.function.name = ubound;
1908 }
1909
1910
1911 /* Resolve the g77 compatibility function UMASK.  */
1912
1913 void
1914 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1915 {
1916   f->ts.type = BT_INTEGER;
1917   f->ts.kind = n->ts.kind;
1918   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1919 }
1920
1921
1922 /* Resolve the g77 compatibility function UNLINK.  */
1923
1924 void
1925 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1926 {
1927   f->ts.type = BT_INTEGER;
1928   f->ts.kind = 4;
1929   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1930 }
1931
1932
1933 void
1934 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
1935 {
1936   gfc_typespec ts;
1937   
1938   f->ts.type = BT_CHARACTER;
1939   f->ts.kind = gfc_default_character_kind;
1940
1941   if (unit->ts.kind != gfc_c_int_kind)
1942     {
1943       ts.type = BT_INTEGER;
1944       ts.kind = gfc_c_int_kind;
1945       ts.derived = NULL;
1946       ts.cl = NULL;
1947       gfc_convert_type (unit, &ts, 2);
1948     }
1949
1950   f->value.function.name = gfc_get_string (PREFIX("ttynam"));
1951 }
1952
1953
1954 void
1955 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1956                     gfc_expr * field ATTRIBUTE_UNUSED)
1957 {
1958   f->ts = vector->ts;
1959   f->rank = mask->rank;
1960
1961   f->value.function.name =
1962     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1963                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1964 }
1965
1966
1967 void
1968 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1969                     gfc_expr * set ATTRIBUTE_UNUSED,
1970                     gfc_expr * back ATTRIBUTE_UNUSED)
1971 {
1972   f->ts.type = BT_INTEGER;
1973   f->ts.kind = gfc_default_integer_kind;
1974   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1975 }
1976
1977
1978 void
1979 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1980 {
1981   f->ts.type = i->ts.type;
1982   f->ts.kind = gfc_kind_max (i,j);
1983
1984   if (i->ts.kind != j->ts.kind)
1985     {
1986       if (i->ts.kind == gfc_kind_max (i,j))
1987         gfc_convert_type(j, &i->ts, 2);
1988       else
1989         gfc_convert_type(i, &j->ts, 2);
1990     }
1991
1992   f->value.function.name = gfc_get_string ("__xor_%c%d",
1993                                            gfc_type_letter (i->ts.type),
1994                                            f->ts.kind);
1995 }
1996
1997
1998 /* Intrinsic subroutine resolution.  */
1999
2000 void
2001 gfc_resolve_alarm_sub (gfc_code * c)
2002 {
2003   const char *name;
2004   gfc_expr *seconds, *handler, *status;
2005   gfc_typespec ts;
2006
2007   seconds = c->ext.actual->expr;
2008   handler = c->ext.actual->next->expr;
2009   status = c->ext.actual->next->next->expr;
2010   ts.type = BT_INTEGER;
2011   ts.kind = gfc_c_int_kind;
2012
2013   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2014   if (handler->ts.type == BT_INTEGER)
2015     {
2016       if (handler->ts.kind != gfc_c_int_kind)
2017         gfc_convert_type (handler, &ts, 2);
2018       name = gfc_get_string (PREFIX("alarm_sub_int"));
2019     }
2020   else
2021     name = gfc_get_string (PREFIX("alarm_sub"));
2022
2023   if (seconds->ts.kind != gfc_c_int_kind)
2024     gfc_convert_type (seconds, &ts, 2);
2025   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2026     gfc_convert_type (status, &ts, 2);
2027
2028   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2029 }
2030
2031 void
2032 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
2033 {
2034   const char *name;
2035
2036   name = gfc_get_string (PREFIX("cpu_time_%d"),
2037                          c->ext.actual->expr->ts.kind);
2038   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2039 }
2040
2041
2042 void
2043 gfc_resolve_mvbits (gfc_code * c)
2044 {
2045   const char *name;
2046   int kind;
2047
2048   kind = c->ext.actual->expr->ts.kind;
2049   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2050
2051   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2052 }
2053
2054
2055 void
2056 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
2057 {
2058   const char *name;
2059   int kind;
2060
2061   kind = c->ext.actual->expr->ts.kind;
2062   if (c->ext.actual->expr->rank == 0)
2063     name = gfc_get_string (PREFIX("random_r%d"), kind);
2064   else
2065     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2066   
2067   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2068 }
2069
2070
2071 void
2072 gfc_resolve_rename_sub (gfc_code * c)
2073 {
2074   const char *name;
2075   int kind;
2076
2077   if (c->ext.actual->next->next->expr != NULL)
2078     kind = c->ext.actual->next->next->expr->ts.kind;
2079   else
2080     kind = gfc_default_integer_kind;
2081
2082   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2083   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2084 }
2085
2086
2087 void
2088 gfc_resolve_kill_sub (gfc_code * c)
2089 {
2090   const char *name;
2091   int kind;
2092
2093   if (c->ext.actual->next->next->expr != NULL)
2094     kind = c->ext.actual->next->next->expr->ts.kind;
2095   else
2096     kind = gfc_default_integer_kind;
2097
2098   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2099   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2100 }
2101     
2102
2103 void
2104 gfc_resolve_link_sub (gfc_code * c)
2105 {
2106   const char *name;
2107   int kind;
2108
2109   if (c->ext.actual->next->next->expr != NULL)
2110     kind = c->ext.actual->next->next->expr->ts.kind;
2111   else
2112     kind = gfc_default_integer_kind;
2113
2114   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2115   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2116 }
2117
2118
2119 void
2120 gfc_resolve_symlnk_sub (gfc_code * c)
2121 {
2122   const char *name;
2123   int kind;
2124
2125   if (c->ext.actual->next->next->expr != NULL)
2126     kind = c->ext.actual->next->next->expr->ts.kind;
2127   else
2128     kind = gfc_default_integer_kind;
2129
2130   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2131   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2132 }
2133
2134
2135 /* G77 compatibility subroutines etime() and dtime().  */
2136
2137 void
2138 gfc_resolve_etime_sub (gfc_code * c)
2139 {
2140   const char *name;
2141
2142   name = gfc_get_string (PREFIX("etime_sub"));
2143   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2144 }
2145
2146
2147 /* G77 compatibility subroutine second().  */
2148
2149 void
2150 gfc_resolve_second_sub (gfc_code * c)
2151 {
2152   const char *name;
2153
2154   name = gfc_get_string (PREFIX("second_sub"));
2155   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2156 }
2157
2158
2159 void
2160 gfc_resolve_sleep_sub (gfc_code * c)
2161 {
2162   const char *name;
2163   int kind;
2164
2165   if (c->ext.actual->expr != NULL)
2166     kind = c->ext.actual->expr->ts.kind;
2167   else
2168     kind = gfc_default_integer_kind;
2169
2170   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2171   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2172 }
2173
2174
2175 /* G77 compatibility function srand().  */
2176
2177 void
2178 gfc_resolve_srand (gfc_code * c)
2179 {
2180   const char *name;
2181   name = gfc_get_string (PREFIX("srand"));
2182   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2183 }
2184
2185
2186 /* Resolve the getarg intrinsic subroutine.  */
2187
2188 void
2189 gfc_resolve_getarg (gfc_code * c)
2190 {
2191   const char *name;
2192   int kind;
2193
2194   kind = gfc_default_integer_kind;
2195   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2196   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2197 }
2198
2199 /* Resolve the getcwd intrinsic subroutine.  */
2200
2201 void
2202 gfc_resolve_getcwd_sub (gfc_code * c)
2203 {
2204   const char *name;
2205   int kind;
2206
2207   if (c->ext.actual->next->expr != NULL)
2208     kind = c->ext.actual->next->expr->ts.kind;
2209   else
2210     kind = gfc_default_integer_kind;
2211
2212   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2213   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2214 }
2215
2216
2217 /* Resolve the get_command intrinsic subroutine.  */
2218
2219 void
2220 gfc_resolve_get_command (gfc_code * c)
2221 {
2222   const char *name;
2223   int kind;
2224
2225   kind = gfc_default_integer_kind;
2226   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2227   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2228 }
2229
2230
2231 /* Resolve the get_command_argument intrinsic subroutine.  */
2232
2233 void
2234 gfc_resolve_get_command_argument (gfc_code * c)
2235 {
2236   const char *name;
2237   int kind;
2238
2239   kind = gfc_default_integer_kind;
2240   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2241   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2242 }
2243
2244 /* Resolve the get_environment_variable intrinsic subroutine.  */
2245
2246 void
2247 gfc_resolve_get_environment_variable (gfc_code * code)
2248 {
2249   const char *name;
2250   int kind;
2251
2252   kind = gfc_default_integer_kind;
2253   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2254   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2255 }
2256
2257 void
2258 gfc_resolve_signal_sub (gfc_code * c)
2259 {
2260   const char *name;
2261   gfc_expr *number, *handler, *status;
2262   gfc_typespec ts;
2263
2264   number = c->ext.actual->expr;
2265   handler = c->ext.actual->next->expr;
2266   status = c->ext.actual->next->next->expr;
2267   ts.type = BT_INTEGER;
2268   ts.kind = gfc_c_int_kind;
2269
2270   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2271   if (handler->ts.type == BT_INTEGER)
2272     {
2273       if (handler->ts.kind != gfc_c_int_kind)
2274         gfc_convert_type (handler, &ts, 2);
2275       name = gfc_get_string (PREFIX("signal_sub_int"));
2276     }
2277   else
2278     name = gfc_get_string (PREFIX("signal_sub"));
2279
2280   if (number->ts.kind != gfc_c_int_kind)
2281     gfc_convert_type (number, &ts, 2);
2282   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2283     gfc_convert_type (status, &ts, 2);
2284
2285   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2286 }
2287
2288 /* Resolve the SYSTEM intrinsic subroutine.  */
2289
2290 void
2291 gfc_resolve_system_sub (gfc_code * c)
2292 {
2293   const char *name;
2294
2295   name = gfc_get_string (PREFIX("system_sub"));
2296   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2297 }
2298
2299 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2300
2301 void
2302 gfc_resolve_system_clock (gfc_code * c)
2303 {
2304   const char *name;
2305   int kind;
2306
2307   if (c->ext.actual->expr != NULL)
2308     kind = c->ext.actual->expr->ts.kind;
2309   else if (c->ext.actual->next->expr != NULL)
2310       kind = c->ext.actual->next->expr->ts.kind;
2311   else if (c->ext.actual->next->next->expr != NULL)
2312       kind = c->ext.actual->next->next->expr->ts.kind;
2313   else
2314     kind = gfc_default_integer_kind;
2315
2316   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2317   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2318 }
2319
2320 /* Resolve the EXIT intrinsic subroutine.  */
2321
2322 void
2323 gfc_resolve_exit (gfc_code * c)
2324 {
2325   const char *name;
2326   int kind;
2327
2328   if (c->ext.actual->expr != NULL)
2329     kind = c->ext.actual->expr->ts.kind;
2330   else
2331     kind = gfc_default_integer_kind;
2332
2333   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2334   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2335 }
2336
2337 /* Resolve the FLUSH intrinsic subroutine.  */
2338
2339 void
2340 gfc_resolve_flush (gfc_code * c)
2341 {
2342   const char *name;
2343   gfc_typespec ts;
2344   gfc_expr *n;
2345
2346   ts.type = BT_INTEGER;
2347   ts.kind = gfc_default_integer_kind;
2348   n = c->ext.actual->expr;
2349   if (n != NULL
2350       && n->ts.kind != ts.kind)
2351     gfc_convert_type (n, &ts, 2);
2352
2353   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2354   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2355 }
2356
2357
2358 void
2359 gfc_resolve_free (gfc_code * c)
2360 {
2361   gfc_typespec ts;
2362   gfc_expr *n;
2363
2364   ts.type = BT_INTEGER;
2365   ts.kind = gfc_index_integer_kind;
2366   n = c->ext.actual->expr;
2367   if (n->ts.kind != ts.kind)
2368     gfc_convert_type (n, &ts, 2);
2369
2370   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2371 }
2372
2373
2374 void
2375 gfc_resolve_ctime_sub (gfc_code * c)
2376 {
2377   gfc_typespec ts;
2378   
2379   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2380   if (c->ext.actual->expr->ts.kind != 8)
2381     {
2382       ts.type = BT_INTEGER;
2383       ts.kind = 8;
2384       ts.derived = NULL;
2385       ts.cl = NULL;
2386       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2387     }
2388
2389   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2390 }
2391
2392
2393 void
2394 gfc_resolve_fdate_sub (gfc_code * c)
2395 {
2396   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2397 }
2398
2399
2400 void
2401 gfc_resolve_gerror (gfc_code * c)
2402 {
2403   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2404 }
2405
2406
2407 void
2408 gfc_resolve_getlog (gfc_code * c)
2409 {
2410   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2411 }
2412
2413
2414 void
2415 gfc_resolve_hostnm_sub (gfc_code * c)
2416 {
2417   const char *name;
2418   int kind;
2419
2420   if (c->ext.actual->next->expr != NULL)
2421     kind = c->ext.actual->next->expr->ts.kind;
2422   else
2423     kind = gfc_default_integer_kind;
2424
2425   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2426   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2427 }
2428
2429
2430 void
2431 gfc_resolve_perror (gfc_code * c)
2432 {
2433   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2434 }
2435
2436 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2437
2438 void
2439 gfc_resolve_stat_sub (gfc_code * c)
2440 {
2441   const char *name;
2442
2443   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2444   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2445 }
2446
2447
2448 void
2449 gfc_resolve_fstat_sub (gfc_code * c)
2450 {
2451   const char *name;
2452   gfc_expr *u;
2453   gfc_typespec *ts;
2454
2455   u = c->ext.actual->expr;
2456   ts = &c->ext.actual->next->expr->ts;
2457   if (u->ts.kind != ts->kind)
2458     gfc_convert_type (u, ts, 2);
2459   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2460   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2461 }
2462
2463
2464 void
2465 gfc_resolve_fgetc_sub (gfc_code * c)
2466 {
2467   const char *name;
2468   gfc_typespec ts;
2469   gfc_expr *u, *st;
2470
2471   u = c->ext.actual->expr;
2472   st = c->ext.actual->next->next->expr;
2473
2474   if (u->ts.kind != gfc_c_int_kind)
2475     {
2476       ts.type = BT_INTEGER;
2477       ts.kind = gfc_c_int_kind;
2478       ts.derived = NULL;
2479       ts.cl = NULL;
2480       gfc_convert_type (u, &ts, 2);
2481     }
2482
2483   if (st != NULL)
2484     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2485   else
2486     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2487
2488   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2489 }
2490
2491
2492 void
2493 gfc_resolve_fget_sub (gfc_code * c)
2494 {
2495   const char *name;
2496   gfc_expr *st;
2497
2498   st = c->ext.actual->next->expr;
2499   if (st != NULL)
2500     name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2501   else
2502     name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2503
2504   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2505 }
2506
2507
2508 void
2509 gfc_resolve_fputc_sub (gfc_code * c)
2510 {
2511   const char *name;
2512   gfc_typespec ts;
2513   gfc_expr *u, *st;
2514
2515   u = c->ext.actual->expr;
2516   st = c->ext.actual->next->next->expr;
2517
2518   if (u->ts.kind != gfc_c_int_kind)
2519     {
2520       ts.type = BT_INTEGER;
2521       ts.kind = gfc_c_int_kind;
2522       ts.derived = NULL;
2523       ts.cl = NULL;
2524       gfc_convert_type (u, &ts, 2);
2525     }
2526
2527   if (st != NULL)
2528     name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2529   else
2530     name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2531
2532   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2533 }
2534
2535
2536 void
2537 gfc_resolve_fput_sub (gfc_code * c)
2538 {
2539   const char *name;
2540   gfc_expr *st;
2541
2542   st = c->ext.actual->next->expr;
2543   if (st != NULL)
2544     name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2545   else
2546     name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2547
2548   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2549 }
2550
2551
2552 void
2553 gfc_resolve_ftell_sub (gfc_code * c)
2554 {
2555   const char *name;
2556   gfc_expr *unit;
2557   gfc_expr *offset;
2558   gfc_typespec ts;
2559
2560   unit = c->ext.actual->expr;
2561   offset = c->ext.actual->next->expr;
2562
2563   if (unit->ts.kind != gfc_c_int_kind)
2564     {
2565       ts.type = BT_INTEGER;
2566       ts.kind = gfc_c_int_kind;
2567       ts.derived = NULL;
2568       ts.cl = NULL;
2569       gfc_convert_type (unit, &ts, 2);
2570     }
2571
2572   name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2573   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2574 }
2575
2576
2577 void
2578 gfc_resolve_ttynam_sub (gfc_code * c)
2579 {
2580   gfc_typespec ts;
2581   
2582   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2583     {
2584       ts.type = BT_INTEGER;
2585       ts.kind = gfc_c_int_kind;
2586       ts.derived = NULL;
2587       ts.cl = NULL;
2588       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2589     }
2590
2591   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2592 }
2593
2594
2595 /* Resolve the UMASK intrinsic subroutine.  */
2596
2597 void
2598 gfc_resolve_umask_sub (gfc_code * c)
2599 {
2600   const char *name;
2601   int kind;
2602
2603   if (c->ext.actual->next->expr != NULL)
2604     kind = c->ext.actual->next->expr->ts.kind;
2605   else
2606     kind = gfc_default_integer_kind;
2607
2608   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2609   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2610 }
2611
2612 /* Resolve the UNLINK intrinsic subroutine.  */
2613
2614 void
2615 gfc_resolve_unlink_sub (gfc_code * c)
2616 {
2617   const char *name;
2618   int kind;
2619
2620   if (c->ext.actual->next->expr != NULL)
2621     kind = c->ext.actual->next->expr->ts.kind;
2622   else
2623     kind = gfc_default_integer_kind;
2624
2625   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2626   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2627 }