OSDN Git Service

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