OSDN Git Service

d07864ee36ee6f81edc4726a03153c2b1565a295
[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   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)
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.  We need to
1998              call the real version.  */
1999           if (kind == 10)
2000             {
2001               f->value.function.name =
2002                 gfc_get_string (PREFIX("transpose_r%d"), kind);
2003               break;
2004             }
2005
2006           /* Fall through */
2007
2008         case BT_INTEGER:
2009         case BT_LOGICAL:
2010           /* Use the integer routines for real and logical cases.  This
2011              assumes they all have the same alignment requirements.  */
2012           f->value.function.name =
2013             gfc_get_string (PREFIX("transpose_i%d"), kind);
2014           break;
2015
2016         default:
2017           f->value.function.name = PREFIX("transpose");
2018           break;
2019         }
2020       break;
2021
2022     default:
2023       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2024                                 ? PREFIX("transpose_char")
2025                                 : PREFIX("transpose"));
2026       break;
2027     }
2028 }
2029
2030
2031 void
2032 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
2033 {
2034   f->ts.type = BT_CHARACTER;
2035   f->ts.kind = string->ts.kind;
2036   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2037 }
2038
2039
2040 void
2041 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
2042                     gfc_expr * dim)
2043 {
2044   static char ubound[] = "__ubound";
2045
2046   f->ts.type = BT_INTEGER;
2047   f->ts.kind = gfc_default_integer_kind;
2048
2049   if (dim == NULL)
2050     {
2051       f->rank = 1;
2052       f->shape = gfc_get_shape (1);
2053       mpz_init_set_ui (f->shape[0], array->rank);
2054     }
2055
2056   f->value.function.name = ubound;
2057 }
2058
2059
2060 /* Resolve the g77 compatibility function UMASK.  */
2061
2062 void
2063 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
2064 {
2065   f->ts.type = BT_INTEGER;
2066   f->ts.kind = n->ts.kind;
2067   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
2068 }
2069
2070
2071 /* Resolve the g77 compatibility function UNLINK.  */
2072
2073 void
2074 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2075 {
2076   f->ts.type = BT_INTEGER;
2077   f->ts.kind = 4;
2078   f->value.function.name = gfc_get_string (PREFIX("unlink"));
2079 }
2080
2081
2082 void
2083 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
2084 {
2085   gfc_typespec ts;
2086   
2087   f->ts.type = BT_CHARACTER;
2088   f->ts.kind = gfc_default_character_kind;
2089
2090   if (unit->ts.kind != gfc_c_int_kind)
2091     {
2092       ts.type = BT_INTEGER;
2093       ts.kind = gfc_c_int_kind;
2094       ts.derived = NULL;
2095       ts.cl = NULL;
2096       gfc_convert_type (unit, &ts, 2);
2097     }
2098
2099   f->value.function.name = gfc_get_string (PREFIX("ttynam"));
2100 }
2101
2102
2103 void
2104 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
2105                     gfc_expr * field ATTRIBUTE_UNUSED)
2106 {
2107   f->ts = vector->ts;
2108   f->rank = mask->rank;
2109
2110   f->value.function.name =
2111     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
2112                     vector->ts.type == BT_CHARACTER ? "_char" : "");
2113 }
2114
2115
2116 void
2117 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
2118                     gfc_expr * set ATTRIBUTE_UNUSED,
2119                     gfc_expr * back ATTRIBUTE_UNUSED)
2120 {
2121   f->ts.type = BT_INTEGER;
2122   f->ts.kind = gfc_default_integer_kind;
2123   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2124 }
2125
2126
2127 void
2128 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
2129 {
2130   f->ts.type = i->ts.type;
2131   f->ts.kind = gfc_kind_max (i,j);
2132
2133   if (i->ts.kind != j->ts.kind)
2134     {
2135       if (i->ts.kind == gfc_kind_max (i,j))
2136         gfc_convert_type(j, &i->ts, 2);
2137       else
2138         gfc_convert_type(i, &j->ts, 2);
2139     }
2140
2141   f->value.function.name = gfc_get_string ("__xor_%c%d",
2142                                            gfc_type_letter (i->ts.type),
2143                                            f->ts.kind);
2144 }
2145
2146
2147 /* Intrinsic subroutine resolution.  */
2148
2149 void
2150 gfc_resolve_alarm_sub (gfc_code * c)
2151 {
2152   const char *name;
2153   gfc_expr *seconds, *handler, *status;
2154   gfc_typespec ts;
2155
2156   seconds = c->ext.actual->expr;
2157   handler = c->ext.actual->next->expr;
2158   status = c->ext.actual->next->next->expr;
2159   ts.type = BT_INTEGER;
2160   ts.kind = gfc_c_int_kind;
2161
2162   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2163   if (handler->ts.type == BT_INTEGER)
2164     {
2165       if (handler->ts.kind != gfc_c_int_kind)
2166         gfc_convert_type (handler, &ts, 2);
2167       name = gfc_get_string (PREFIX("alarm_sub_int"));
2168     }
2169   else
2170     name = gfc_get_string (PREFIX("alarm_sub"));
2171
2172   if (seconds->ts.kind != gfc_c_int_kind)
2173     gfc_convert_type (seconds, &ts, 2);
2174   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2175     gfc_convert_type (status, &ts, 2);
2176
2177   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2178 }
2179
2180 void
2181 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
2182 {
2183   const char *name;
2184
2185   name = gfc_get_string (PREFIX("cpu_time_%d"),
2186                          c->ext.actual->expr->ts.kind);
2187   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2188 }
2189
2190
2191 void
2192 gfc_resolve_mvbits (gfc_code * c)
2193 {
2194   const char *name;
2195   int kind;
2196
2197   kind = c->ext.actual->expr->ts.kind;
2198   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2199
2200   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2201 }
2202
2203
2204 void
2205 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
2206 {
2207   const char *name;
2208   int kind;
2209
2210   kind = c->ext.actual->expr->ts.kind;
2211   if (c->ext.actual->expr->rank == 0)
2212     name = gfc_get_string (PREFIX("random_r%d"), kind);
2213   else
2214     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2215   
2216   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2217 }
2218
2219
2220 void
2221 gfc_resolve_rename_sub (gfc_code * c)
2222 {
2223   const char *name;
2224   int kind;
2225
2226   if (c->ext.actual->next->next->expr != NULL)
2227     kind = c->ext.actual->next->next->expr->ts.kind;
2228   else
2229     kind = gfc_default_integer_kind;
2230
2231   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2232   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2233 }
2234
2235
2236 void
2237 gfc_resolve_kill_sub (gfc_code * c)
2238 {
2239   const char *name;
2240   int kind;
2241
2242   if (c->ext.actual->next->next->expr != NULL)
2243     kind = c->ext.actual->next->next->expr->ts.kind;
2244   else
2245     kind = gfc_default_integer_kind;
2246
2247   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2248   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2249 }
2250     
2251
2252 void
2253 gfc_resolve_link_sub (gfc_code * c)
2254 {
2255   const char *name;
2256   int kind;
2257
2258   if (c->ext.actual->next->next->expr != NULL)
2259     kind = c->ext.actual->next->next->expr->ts.kind;
2260   else
2261     kind = gfc_default_integer_kind;
2262
2263   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2264   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2265 }
2266
2267
2268 void
2269 gfc_resolve_symlnk_sub (gfc_code * c)
2270 {
2271   const char *name;
2272   int kind;
2273
2274   if (c->ext.actual->next->next->expr != NULL)
2275     kind = c->ext.actual->next->next->expr->ts.kind;
2276   else
2277     kind = gfc_default_integer_kind;
2278
2279   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2280   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2281 }
2282
2283
2284 /* G77 compatibility subroutines etime() and dtime().  */
2285
2286 void
2287 gfc_resolve_etime_sub (gfc_code * c)
2288 {
2289   const char *name;
2290
2291   name = gfc_get_string (PREFIX("etime_sub"));
2292   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2293 }
2294
2295
2296 /* G77 compatibility subroutine second().  */
2297
2298 void
2299 gfc_resolve_second_sub (gfc_code * c)
2300 {
2301   const char *name;
2302
2303   name = gfc_get_string (PREFIX("second_sub"));
2304   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2305 }
2306
2307
2308 void
2309 gfc_resolve_sleep_sub (gfc_code * c)
2310 {
2311   const char *name;
2312   int kind;
2313
2314   if (c->ext.actual->expr != NULL)
2315     kind = c->ext.actual->expr->ts.kind;
2316   else
2317     kind = gfc_default_integer_kind;
2318
2319   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2320   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2321 }
2322
2323
2324 /* G77 compatibility function srand().  */
2325
2326 void
2327 gfc_resolve_srand (gfc_code * c)
2328 {
2329   const char *name;
2330   name = gfc_get_string (PREFIX("srand"));
2331   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2332 }
2333
2334
2335 /* Resolve the getarg intrinsic subroutine.  */
2336
2337 void
2338 gfc_resolve_getarg (gfc_code * c)
2339 {
2340   const char *name;
2341   int kind;
2342
2343   kind = gfc_default_integer_kind;
2344   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2345   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2346 }
2347
2348 /* Resolve the getcwd intrinsic subroutine.  */
2349
2350 void
2351 gfc_resolve_getcwd_sub (gfc_code * c)
2352 {
2353   const char *name;
2354   int kind;
2355
2356   if (c->ext.actual->next->expr != NULL)
2357     kind = c->ext.actual->next->expr->ts.kind;
2358   else
2359     kind = gfc_default_integer_kind;
2360
2361   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2362   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2363 }
2364
2365
2366 /* Resolve the get_command intrinsic subroutine.  */
2367
2368 void
2369 gfc_resolve_get_command (gfc_code * c)
2370 {
2371   const char *name;
2372   int kind;
2373
2374   kind = gfc_default_integer_kind;
2375   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2376   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2377 }
2378
2379
2380 /* Resolve the get_command_argument intrinsic subroutine.  */
2381
2382 void
2383 gfc_resolve_get_command_argument (gfc_code * c)
2384 {
2385   const char *name;
2386   int kind;
2387
2388   kind = gfc_default_integer_kind;
2389   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2390   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2391 }
2392
2393 /* Resolve the get_environment_variable intrinsic subroutine.  */
2394
2395 void
2396 gfc_resolve_get_environment_variable (gfc_code * code)
2397 {
2398   const char *name;
2399   int kind;
2400
2401   kind = gfc_default_integer_kind;
2402   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2403   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2404 }
2405
2406 void
2407 gfc_resolve_signal_sub (gfc_code * c)
2408 {
2409   const char *name;
2410   gfc_expr *number, *handler, *status;
2411   gfc_typespec ts;
2412
2413   number = c->ext.actual->expr;
2414   handler = c->ext.actual->next->expr;
2415   status = c->ext.actual->next->next->expr;
2416   ts.type = BT_INTEGER;
2417   ts.kind = gfc_c_int_kind;
2418
2419   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2420   if (handler->ts.type == BT_INTEGER)
2421     {
2422       if (handler->ts.kind != gfc_c_int_kind)
2423         gfc_convert_type (handler, &ts, 2);
2424       name = gfc_get_string (PREFIX("signal_sub_int"));
2425     }
2426   else
2427     name = gfc_get_string (PREFIX("signal_sub"));
2428
2429   if (number->ts.kind != gfc_c_int_kind)
2430     gfc_convert_type (number, &ts, 2);
2431   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2432     gfc_convert_type (status, &ts, 2);
2433
2434   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2435 }
2436
2437 /* Resolve the SYSTEM intrinsic subroutine.  */
2438
2439 void
2440 gfc_resolve_system_sub (gfc_code * c)
2441 {
2442   const char *name;
2443
2444   name = gfc_get_string (PREFIX("system_sub"));
2445   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2446 }
2447
2448 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2449
2450 void
2451 gfc_resolve_system_clock (gfc_code * c)
2452 {
2453   const char *name;
2454   int kind;
2455
2456   if (c->ext.actual->expr != NULL)
2457     kind = c->ext.actual->expr->ts.kind;
2458   else if (c->ext.actual->next->expr != NULL)
2459       kind = c->ext.actual->next->expr->ts.kind;
2460   else if (c->ext.actual->next->next->expr != NULL)
2461       kind = c->ext.actual->next->next->expr->ts.kind;
2462   else
2463     kind = gfc_default_integer_kind;
2464
2465   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2466   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2467 }
2468
2469 /* Resolve the EXIT intrinsic subroutine.  */
2470
2471 void
2472 gfc_resolve_exit (gfc_code * c)
2473 {
2474   const char *name;
2475   int kind;
2476
2477   if (c->ext.actual->expr != NULL)
2478     kind = c->ext.actual->expr->ts.kind;
2479   else
2480     kind = gfc_default_integer_kind;
2481
2482   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2483   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2484 }
2485
2486 /* Resolve the FLUSH intrinsic subroutine.  */
2487
2488 void
2489 gfc_resolve_flush (gfc_code * c)
2490 {
2491   const char *name;
2492   gfc_typespec ts;
2493   gfc_expr *n;
2494
2495   ts.type = BT_INTEGER;
2496   ts.kind = gfc_default_integer_kind;
2497   n = c->ext.actual->expr;
2498   if (n != NULL
2499       && n->ts.kind != ts.kind)
2500     gfc_convert_type (n, &ts, 2);
2501
2502   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2503   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2504 }
2505
2506
2507 void
2508 gfc_resolve_free (gfc_code * c)
2509 {
2510   gfc_typespec ts;
2511   gfc_expr *n;
2512
2513   ts.type = BT_INTEGER;
2514   ts.kind = gfc_index_integer_kind;
2515   n = c->ext.actual->expr;
2516   if (n->ts.kind != ts.kind)
2517     gfc_convert_type (n, &ts, 2);
2518
2519   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2520 }
2521
2522
2523 void
2524 gfc_resolve_ctime_sub (gfc_code * c)
2525 {
2526   gfc_typespec ts;
2527   
2528   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2529   if (c->ext.actual->expr->ts.kind != 8)
2530     {
2531       ts.type = BT_INTEGER;
2532       ts.kind = 8;
2533       ts.derived = NULL;
2534       ts.cl = NULL;
2535       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2536     }
2537
2538   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2539 }
2540
2541
2542 void
2543 gfc_resolve_fdate_sub (gfc_code * c)
2544 {
2545   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2546 }
2547
2548
2549 void
2550 gfc_resolve_gerror (gfc_code * c)
2551 {
2552   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2553 }
2554
2555
2556 void
2557 gfc_resolve_getlog (gfc_code * c)
2558 {
2559   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2560 }
2561
2562
2563 void
2564 gfc_resolve_hostnm_sub (gfc_code * c)
2565 {
2566   const char *name;
2567   int kind;
2568
2569   if (c->ext.actual->next->expr != NULL)
2570     kind = c->ext.actual->next->expr->ts.kind;
2571   else
2572     kind = gfc_default_integer_kind;
2573
2574   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2575   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2576 }
2577
2578
2579 void
2580 gfc_resolve_perror (gfc_code * c)
2581 {
2582   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2583 }
2584
2585 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2586
2587 void
2588 gfc_resolve_stat_sub (gfc_code * c)
2589 {
2590   const char *name;
2591
2592   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2593   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2594 }
2595
2596
2597 void
2598 gfc_resolve_fstat_sub (gfc_code * c)
2599 {
2600   const char *name;
2601   gfc_expr *u;
2602   gfc_typespec *ts;
2603
2604   u = c->ext.actual->expr;
2605   ts = &c->ext.actual->next->expr->ts;
2606   if (u->ts.kind != ts->kind)
2607     gfc_convert_type (u, ts, 2);
2608   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2609   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2610 }
2611
2612
2613 void
2614 gfc_resolve_fgetc_sub (gfc_code * c)
2615 {
2616   const char *name;
2617   gfc_typespec ts;
2618   gfc_expr *u, *st;
2619
2620   u = c->ext.actual->expr;
2621   st = c->ext.actual->next->next->expr;
2622
2623   if (u->ts.kind != gfc_c_int_kind)
2624     {
2625       ts.type = BT_INTEGER;
2626       ts.kind = gfc_c_int_kind;
2627       ts.derived = NULL;
2628       ts.cl = NULL;
2629       gfc_convert_type (u, &ts, 2);
2630     }
2631
2632   if (st != NULL)
2633     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2634   else
2635     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2636
2637   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2638 }
2639
2640
2641 void
2642 gfc_resolve_fget_sub (gfc_code * c)
2643 {
2644   const char *name;
2645   gfc_expr *st;
2646
2647   st = c->ext.actual->next->expr;
2648   if (st != NULL)
2649     name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2650   else
2651     name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2652
2653   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2654 }
2655
2656
2657 void
2658 gfc_resolve_fputc_sub (gfc_code * c)
2659 {
2660   const char *name;
2661   gfc_typespec ts;
2662   gfc_expr *u, *st;
2663
2664   u = c->ext.actual->expr;
2665   st = c->ext.actual->next->next->expr;
2666
2667   if (u->ts.kind != gfc_c_int_kind)
2668     {
2669       ts.type = BT_INTEGER;
2670       ts.kind = gfc_c_int_kind;
2671       ts.derived = NULL;
2672       ts.cl = NULL;
2673       gfc_convert_type (u, &ts, 2);
2674     }
2675
2676   if (st != NULL)
2677     name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2678   else
2679     name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2680
2681   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2682 }
2683
2684
2685 void
2686 gfc_resolve_fput_sub (gfc_code * c)
2687 {
2688   const char *name;
2689   gfc_expr *st;
2690
2691   st = c->ext.actual->next->expr;
2692   if (st != NULL)
2693     name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2694   else
2695     name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2696
2697   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2698 }
2699
2700
2701 void
2702 gfc_resolve_ftell_sub (gfc_code * c)
2703 {
2704   const char *name;
2705   gfc_expr *unit;
2706   gfc_expr *offset;
2707   gfc_typespec ts;
2708
2709   unit = c->ext.actual->expr;
2710   offset = c->ext.actual->next->expr;
2711
2712   if (unit->ts.kind != gfc_c_int_kind)
2713     {
2714       ts.type = BT_INTEGER;
2715       ts.kind = gfc_c_int_kind;
2716       ts.derived = NULL;
2717       ts.cl = NULL;
2718       gfc_convert_type (unit, &ts, 2);
2719     }
2720
2721   name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2722   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2723 }
2724
2725
2726 void
2727 gfc_resolve_ttynam_sub (gfc_code * c)
2728 {
2729   gfc_typespec ts;
2730   
2731   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2732     {
2733       ts.type = BT_INTEGER;
2734       ts.kind = gfc_c_int_kind;
2735       ts.derived = NULL;
2736       ts.cl = NULL;
2737       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2738     }
2739
2740   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2741 }
2742
2743
2744 /* Resolve the UMASK intrinsic subroutine.  */
2745
2746 void
2747 gfc_resolve_umask_sub (gfc_code * c)
2748 {
2749   const char *name;
2750   int kind;
2751
2752   if (c->ext.actual->next->expr != NULL)
2753     kind = c->ext.actual->next->expr->ts.kind;
2754   else
2755     kind = gfc_default_integer_kind;
2756
2757   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2758   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2759 }
2760
2761 /* Resolve the UNLINK intrinsic subroutine.  */
2762
2763 void
2764 gfc_resolve_unlink_sub (gfc_code * c)
2765 {
2766   const char *name;
2767   int kind;
2768
2769   if (c->ext.actual->next->expr != NULL)
2770     kind = c->ext.actual->next->expr->ts.kind;
2771   else
2772     kind = gfc_default_integer_kind;
2773
2774   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2775   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2776 }