OSDN Git Service

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