OSDN Git Service

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