OSDN Git Service

gcc/fortran/
[pf3gnuchains/gcc-fork.git] / gcc / fortran / iresolve.c
1 /* Intrinsic function resolution.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
3    Inc.
4    Contributed by Andy Vaught & Katherine Holcomb
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.  */
22
23
24 /* Assign name and types to intrinsic procedures.  For functions, the
25    first argument to a resolution function is an expression pointer to
26    the original function node and the rest are pointers to the
27    arguments of the function call.  For subroutines, a pointer to the
28    code node is passed.  The result type and library subroutine name
29    are generally set according to the function arguments.  */
30
31 #include "config.h"
32 #include <string.h>
33 #include <stdarg.h>
34
35 #include "gfortran.h"
36 #include "intrinsic.h"
37
38
39 /* String pool subroutines.  This are used to provide static locations
40    for the string constants that represent library function names.  */
41
42 typedef struct string_node
43 {
44   struct string_node *next;
45   char string[1];
46 }
47 string_node;
48
49 #define HASH_SIZE 13
50
51 static string_node *string_head[HASH_SIZE];
52
53
54 /* Return a hash code based on the name.  */
55
56 static int
57 hash (const char *name)
58 {
59   int h;
60
61   h = 1;
62   while (*name)
63     h = 5311966 * h + *name++;
64
65   if (h < 0)
66     h = -h;
67   return h % HASH_SIZE;
68 }
69
70
71 /* Given printf-like arguments, return a static address of the
72    resulting string.  If the name is not in the table, it is added.  */
73
74 char *
75 gfc_get_string (const char *format, ...)
76 {
77   char temp_name[50];
78   string_node *p;
79   va_list ap;
80   int h;
81
82   va_start (ap, format);
83   vsprintf (temp_name, format, ap);
84   va_end (ap);
85
86   h = hash (temp_name);
87
88   /* Search */
89   for (p = string_head[h]; p; p = p->next)
90     if (strcmp (p->string, temp_name) == 0)
91       return p->string;
92
93   /* Add */
94   p = gfc_getmem (sizeof (string_node) + strlen (temp_name));
95
96   strcpy (p->string, temp_name);
97
98   p->next = string_head[h];
99   string_head[h] = p;
100
101   return p->string;
102 }
103
104
105
106 static void
107 free_strings (void)
108 {
109   string_node *p, *q;
110   int h;
111
112   for (h = 0; h < HASH_SIZE; h++)
113     {
114       for (p = string_head[h]; p; p = q)
115         {
116           q = p->next;
117           gfc_free (p);
118         }
119     }
120 }
121
122
123 /********************** Resolution functions **********************/
124
125
126 void
127 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
128 {
129   f->ts = a->ts;
130   if (f->ts.type == BT_COMPLEX)
131     f->ts.type = BT_REAL;
132
133   f->value.function.name =
134     gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
135 }
136
137
138 void
139 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
140 {
141   f->ts = x->ts;
142   f->value.function.name =
143     gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
144 }
145
146
147 void
148 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
149 {
150   f->ts.type = BT_REAL;
151   f->ts.kind = x->ts.kind;
152   f->value.function.name =
153     gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
154 }
155
156
157 void
158 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
159 {
160   f->ts.type = a->ts.type;
161   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
162
163   /* The resolved name is only used for specific intrinsics where
164      the return kind is the same as the arg kind.  */
165   f->value.function.name =
166     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
167 }
168
169
170 void
171 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
172 {
173   gfc_resolve_aint (f, a, NULL);
174 }
175
176
177 void
178 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
179 {
180   f->ts = mask->ts;
181
182   if (dim != NULL)
183     {
184       gfc_resolve_index (dim, 1);
185       f->rank = mask->rank - 1;
186       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
187     }
188
189   f->value.function.name =
190     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
191                     mask->ts.kind);
192 }
193
194
195 void
196 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
197 {
198   f->ts.type = a->ts.type;
199   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
200
201   /* The resolved name is only used for specific intrinsics where
202      the return kind is the same as the arg kind.  */
203   f->value.function.name =
204     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
205 }
206
207
208 void
209 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
210 {
211   gfc_resolve_anint (f, a, NULL);
212 }
213
214
215 void
216 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
217 {
218   f->ts = mask->ts;
219
220   if (dim != NULL)
221     {
222       gfc_resolve_index (dim, 1);
223       f->rank = mask->rank - 1;
224       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
225     }
226
227   f->value.function.name =
228     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
229                     mask->ts.kind);
230 }
231
232
233 void
234 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
235 {
236   f->ts = x->ts;
237   f->value.function.name =
238     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
239 }
240
241
242 void
243 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
244 {
245   f->ts = x->ts;
246   f->value.function.name =
247     gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
248 }
249
250
251 void
252 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
253                    gfc_expr * y ATTRIBUTE_UNUSED)
254 {
255   f->ts = x->ts;
256   f->value.function.name =
257     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
258 }
259
260
261 /* Resolve the BESYN and BESJN intrinsics.  */
262
263 void
264 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
265 {
266   gfc_typespec ts;
267   
268   f->ts = x->ts;
269   if (n->ts.kind != gfc_c_int_kind)
270     {
271       ts.type = BT_INTEGER;
272       ts.kind = gfc_c_int_kind;
273       gfc_convert_type (n, &ts, 2);
274     }
275   f->value.function.name = gfc_get_string ("<intrinsic>");
276 }
277
278
279 void
280 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
281 {
282   f->ts.type = BT_LOGICAL;
283   f->ts.kind = gfc_default_logical_kind;
284
285   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
286                                            pos->ts.kind);
287 }
288
289
290 void
291 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
292 {
293   f->ts.type = BT_INTEGER;
294   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
295     : mpz_get_si (kind->value.integer);
296
297   f->value.function.name =
298     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
299                     gfc_type_letter (a->ts.type), a->ts.kind);
300 }
301
302
303 void
304 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
305 {
306   f->ts.type = BT_CHARACTER;
307   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
308     : mpz_get_si (kind->value.integer);
309
310   f->value.function.name =
311     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
312                     gfc_type_letter (a->ts.type), a->ts.kind);
313 }
314
315
316 void
317 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
318 {
319   f->ts.type = BT_COMPLEX;
320   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
321     : mpz_get_si (kind->value.integer);
322
323   if (y == NULL)
324     f->value.function.name =
325       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
326                       gfc_type_letter (x->ts.type), x->ts.kind);
327   else
328     f->value.function.name =
329       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
330                       gfc_type_letter (x->ts.type), x->ts.kind,
331                       gfc_type_letter (y->ts.type), y->ts.kind);
332 }
333
334 void
335 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
336 {
337   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
338 }
339
340 void
341 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
342 {
343   f->ts = x->ts;
344   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
345 }
346
347
348 void
349 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
350 {
351   f->ts = x->ts;
352   f->value.function.name =
353     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
354 }
355
356
357 void
358 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
359 {
360   f->ts = x->ts;
361   f->value.function.name =
362     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
363 }
364
365
366 void
367 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
368 {
369   f->ts.type = BT_INTEGER;
370   f->ts.kind = gfc_default_integer_kind;
371
372   if (dim != NULL)
373     {
374       f->rank = mask->rank - 1;
375       gfc_resolve_index (dim, 1);
376       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
377     }
378
379   f->value.function.name =
380     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
381                     gfc_type_letter (mask->ts.type), mask->ts.kind);
382 }
383
384
385 void
386 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
387                     gfc_expr * shift,
388                     gfc_expr * dim)
389 {
390   int n;
391
392   f->ts = array->ts;
393   f->rank = array->rank;
394   f->shape = gfc_copy_shape (array->shape, array->rank);
395
396   if (shift->rank > 0)
397     n = 1;
398   else
399     n = 0;
400
401   if (dim != NULL)
402     {
403       gfc_resolve_index (dim, 1);
404       /* Convert dim to shift's kind, so we don't need so many variations.  */
405       if (dim->ts.kind != shift->ts.kind)
406         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
407     }
408   f->value.function.name =
409     gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
410 }
411
412
413 void
414 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
415 {
416   f->ts.type = BT_REAL;
417   f->ts.kind = gfc_default_double_kind;
418   f->value.function.name =
419     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
420 }
421
422
423 void
424 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
425                  gfc_expr * y ATTRIBUTE_UNUSED)
426 {
427   f->ts = x->ts;
428   f->value.function.name =
429     gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
430 }
431
432
433 void
434 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
435 {
436   gfc_expr temp;
437
438   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
439     {
440       f->ts.type = BT_LOGICAL;
441       f->ts.kind = gfc_default_logical_kind;
442     }
443   else
444     {
445       temp.expr_type = EXPR_OP;
446       gfc_clear_ts (&temp.ts);
447       temp.operator = INTRINSIC_NONE;
448       temp.op1 = a;
449       temp.op2 = b;
450       gfc_type_convert_binary (&temp);
451       f->ts = temp.ts;
452     }
453
454   f->value.function.name =
455     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
456                     f->ts.kind);
457 }
458
459
460 void
461 gfc_resolve_dprod (gfc_expr * f,
462                    gfc_expr * a ATTRIBUTE_UNUSED,
463                    gfc_expr * b ATTRIBUTE_UNUSED)
464 {
465   f->ts.kind = gfc_default_double_kind;
466   f->ts.type = BT_REAL;
467
468   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
469 }
470
471
472 void
473 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
474                      gfc_expr * shift,
475                      gfc_expr * boundary,
476                      gfc_expr * dim)
477 {
478   int n;
479
480   f->ts = array->ts;
481   f->rank = array->rank;
482   f->shape = gfc_copy_shape (array->shape, array->rank);
483
484   n = 0;
485   if (shift->rank > 0)
486     n = n | 1;
487   if (boundary && boundary->rank > 0)
488     n = n | 2;
489
490   /* Convert dim to the same type as shift, so we don't need quite so many
491      variations.  */
492   if (dim != NULL && dim->ts.kind != shift->ts.kind)
493     gfc_convert_type_warn (dim, &shift->ts, 2, 0);
494
495   f->value.function.name =
496     gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
497 }
498
499
500 void
501 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
502 {
503   f->ts = x->ts;
504   f->value.function.name =
505     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
506 }
507
508
509 void
510 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
511 {
512   f->ts.type = BT_INTEGER;
513   f->ts.kind = gfc_default_integer_kind;
514
515   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
516 }
517
518
519 void
520 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
521 {
522   f->ts.type = BT_INTEGER;
523   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
524     : mpz_get_si (kind->value.integer);
525
526   f->value.function.name =
527     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
528                     gfc_type_letter (a->ts.type), a->ts.kind);
529 }
530
531
532 void
533 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
534 {
535   f->ts.type = BT_INTEGER;
536   f->ts.kind = gfc_default_integer_kind;
537   if (n->ts.kind != f->ts.kind)
538     gfc_convert_type (n, &f->ts, 2);
539   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
540 }
541
542
543 void
544 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
545 {
546   f->ts = x->ts;
547   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
548 }
549
550
551 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
552
553 void
554 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
555 {
556   f->ts = x->ts;
557   f->value.function.name = gfc_get_string ("<intrinsic>");
558 }
559
560
561 void
562 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
563 {
564   f->ts.type = BT_INTEGER;
565   f->ts.kind = 4;
566   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
567 }
568
569
570 void
571 gfc_resolve_getgid (gfc_expr * f)
572 {
573   f->ts.type = BT_INTEGER;
574   f->ts.kind = 4;
575   f->value.function.name = gfc_get_string (PREFIX("getgid"));
576 }
577
578
579 void
580 gfc_resolve_getpid (gfc_expr * f)
581 {
582   f->ts.type = BT_INTEGER;
583   f->ts.kind = 4;
584   f->value.function.name = gfc_get_string (PREFIX("getpid"));
585 }
586
587
588 void
589 gfc_resolve_getuid (gfc_expr * f)
590 {
591   f->ts.type = BT_INTEGER;
592   f->ts.kind = 4;
593   f->value.function.name = gfc_get_string (PREFIX("getuid"));
594 }
595
596 void
597 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
598 {
599   /* If the kind of i and j are different, then g77 cross-promoted the
600      kinds to the largest value.  The Fortran 95 standard requires the 
601      kinds to match.  */
602   if (i->ts.kind != j->ts.kind)
603     {
604       if (i->ts.kind == gfc_kind_max (i,j))
605         gfc_convert_type(j, &i->ts, 2);
606       else
607         gfc_convert_type(i, &j->ts, 2);
608     }
609
610   f->ts = i->ts;
611   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
612 }
613
614
615 void
616 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
617 {
618   f->ts = i->ts;
619   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
620 }
621
622
623 void
624 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
625                    gfc_expr * pos ATTRIBUTE_UNUSED,
626                    gfc_expr * len ATTRIBUTE_UNUSED)
627 {
628   f->ts = i->ts;
629   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
630 }
631
632
633 void
634 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
635                    gfc_expr * pos ATTRIBUTE_UNUSED)
636 {
637   f->ts = i->ts;
638   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
639 }
640
641
642 void
643 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
644 {
645   f->ts.type = BT_INTEGER;
646   f->ts.kind = gfc_default_integer_kind;
647
648   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
649 }
650
651
652 void
653 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
654 {
655   gfc_resolve_nint (f, a, NULL);
656 }
657
658
659 void
660 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
661 {
662   /* If the kind of i and j are different, then g77 cross-promoted the
663      kinds to the largest value.  The Fortran 95 standard requires the 
664      kinds to match.  */
665   if (i->ts.kind != j->ts.kind)
666     {
667       if (i->ts.kind == gfc_kind_max (i,j))
668         gfc_convert_type(j, &i->ts, 2);
669       else
670         gfc_convert_type(i, &j->ts, 2);
671     }
672
673   f->ts = i->ts;
674   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
675 }
676
677
678 void
679 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
680 {
681   /* If the kind of i and j are different, then g77 cross-promoted the
682      kinds to the largest value.  The Fortran 95 standard requires the 
683      kinds to match.  */
684   if (i->ts.kind != j->ts.kind)
685     {
686       if (i->ts.kind == gfc_kind_max (i,j))
687         gfc_convert_type(j, &i->ts, 2);
688       else
689         gfc_convert_type(i, &j->ts, 2);
690     }
691
692   f->ts = i->ts;
693   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
694 }
695
696
697 void
698 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
699 {
700   f->ts.type = BT_INTEGER;
701   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
702     : mpz_get_si (kind->value.integer);
703
704   f->value.function.name =
705     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
706                     a->ts.kind);
707 }
708
709
710 void
711 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
712 {
713   f->ts = i->ts;
714   f->value.function.name =
715     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
716 }
717
718
719 void
720 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
721                     gfc_expr * size)
722 {
723   int s_kind;
724
725   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
726
727   f->ts = i->ts;
728   f->value.function.name =
729     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
730 }
731
732
733 void
734 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
735                     gfc_expr * dim)
736 {
737   static char lbound[] = "__lbound";
738
739   f->ts.type = BT_INTEGER;
740   f->ts.kind = gfc_default_integer_kind;
741
742   if (dim == NULL)
743     {
744       f->rank = 1;
745       f->shape = gfc_get_shape (1);
746       mpz_init_set_ui (f->shape[0], array->rank);
747     }
748
749   f->value.function.name = lbound;
750 }
751
752
753 void
754 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
755 {
756   f->ts.type = BT_INTEGER;
757   f->ts.kind = gfc_default_integer_kind;
758   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
759 }
760
761
762 void
763 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
764 {
765   f->ts.type = BT_INTEGER;
766   f->ts.kind = gfc_default_integer_kind;
767   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
768 }
769
770
771 void
772 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
773 {
774   f->ts = x->ts;
775   f->value.function.name =
776     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
777 }
778
779
780 void
781 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
782 {
783   f->ts = x->ts;
784   f->value.function.name =
785     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
786 }
787
788
789 void
790 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
791 {
792   f->ts.type = BT_LOGICAL;
793   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
794     : mpz_get_si (kind->value.integer);
795   f->rank = a->rank;
796
797   f->value.function.name =
798     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
799                     gfc_type_letter (a->ts.type), a->ts.kind);
800 }
801
802
803 void
804 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
805 {
806   gfc_expr temp;
807
808   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
809     {
810       f->ts.type = BT_LOGICAL;
811       f->ts.kind = gfc_default_logical_kind;
812     }
813   else
814     {
815       temp.expr_type = EXPR_OP;
816       gfc_clear_ts (&temp.ts);
817       temp.operator = INTRINSIC_NONE;
818       temp.op1 = a;
819       temp.op2 = b;
820       gfc_type_convert_binary (&temp);
821       f->ts = temp.ts;
822     }
823
824   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
825
826   f->value.function.name =
827     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
828                     f->ts.kind);
829 }
830
831
832 static void
833 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
834 {
835   gfc_actual_arglist *a;
836
837   f->ts.type = args->expr->ts.type;
838   f->ts.kind = args->expr->ts.kind;
839   /* Find the largest type kind.  */
840   for (a = args->next; a; a = a->next)
841     {
842       if (a->expr->ts.kind > f->ts.kind)
843         f->ts.kind = a->expr->ts.kind;
844     }
845
846   /* Convert all parameters to the required kind.  */
847   for (a = args; a; a = a->next)
848     {
849       if (a->expr->ts.kind != f->ts.kind)
850         gfc_convert_type (a->expr, &f->ts, 2);
851     }
852
853   f->value.function.name =
854     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
855 }
856
857
858 void
859 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
860 {
861   gfc_resolve_minmax ("__max_%c%d", f, args);
862 }
863
864
865 void
866 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
867                     gfc_expr * mask)
868 {
869   const char *name;
870
871   f->ts.type = BT_INTEGER;
872   f->ts.kind = gfc_default_integer_kind;
873
874   if (dim == NULL)
875     f->rank = 1;
876   else
877     {
878       f->rank = array->rank - 1;
879       gfc_resolve_index (dim, 1);
880     }
881
882   name = mask ? "mmaxloc" : "maxloc";
883   f->value.function.name =
884     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
885                     gfc_type_letter (array->ts.type), array->ts.kind);
886 }
887
888
889 void
890 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
891                     gfc_expr * mask)
892 {
893   f->ts = array->ts;
894
895   if (dim != NULL)
896     {
897       f->rank = array->rank - 1;
898       gfc_resolve_index (dim, 1);
899     }
900
901   f->value.function.name =
902     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
903                     gfc_type_letter (array->ts.type), array->ts.kind);
904 }
905
906
907 void
908 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
909                    gfc_expr * fsource ATTRIBUTE_UNUSED,
910                    gfc_expr * mask ATTRIBUTE_UNUSED)
911 {
912   f->ts = tsource->ts;
913   f->value.function.name =
914     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
915                     tsource->ts.kind);
916 }
917
918
919 void
920 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
921 {
922   gfc_resolve_minmax ("__min_%c%d", f, args);
923 }
924
925
926 void
927 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
928                     gfc_expr * mask)
929 {
930   const char *name;
931
932   f->ts.type = BT_INTEGER;
933   f->ts.kind = gfc_default_integer_kind;
934
935   if (dim == NULL)
936     f->rank = 1;
937   else
938     {
939       f->rank = array->rank - 1;
940       gfc_resolve_index (dim, 1);
941     }
942
943   name = mask ? "mminloc" : "minloc";
944   f->value.function.name =
945     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
946                     gfc_type_letter (array->ts.type), array->ts.kind);
947 }
948
949
950 void
951 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
952                     gfc_expr * mask)
953 {
954   f->ts = array->ts;
955
956   if (dim != NULL)
957     {
958       f->rank = array->rank - 1;
959       gfc_resolve_index (dim, 1);
960     }
961
962   f->value.function.name =
963     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
964                     gfc_type_letter (array->ts.type), array->ts.kind);
965 }
966
967
968 void
969 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
970                  gfc_expr * p ATTRIBUTE_UNUSED)
971 {
972   f->ts = a->ts;
973   f->value.function.name =
974     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
975 }
976
977
978 void
979 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
980                     gfc_expr * p ATTRIBUTE_UNUSED)
981 {
982   f->ts = a->ts;
983   f->value.function.name =
984     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
985                     a->ts.kind);
986 }
987
988 void
989 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
990 {
991   f->ts = a->ts;
992   f->value.function.name =
993     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
994             a->ts.kind);
995 }
996
997 void
998 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
999 {
1000   f->ts.type = BT_INTEGER;
1001   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1002     : mpz_get_si (kind->value.integer);
1003
1004   f->value.function.name =
1005     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1006 }
1007
1008
1009 void
1010 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1011 {
1012   f->ts = i->ts;
1013   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1014 }
1015
1016
1017 void
1018 gfc_resolve_pack (gfc_expr * f,
1019                   gfc_expr * array ATTRIBUTE_UNUSED,
1020                   gfc_expr * mask,
1021                   gfc_expr * vector ATTRIBUTE_UNUSED)
1022 {
1023   f->ts = array->ts;
1024   f->rank = 1;
1025
1026   if (mask->rank != 0)
1027     f->value.function.name = PREFIX("pack");
1028   else
1029     {
1030       /* We convert mask to default logical only in the scalar case.
1031          In the array case we can simply read the array as if it were
1032          of type default logical.  */
1033       if (mask->ts.kind != gfc_default_logical_kind)
1034         {
1035           gfc_typespec ts;
1036
1037           ts.type = BT_LOGICAL;
1038           ts.kind = gfc_default_logical_kind;
1039           gfc_convert_type (mask, &ts, 2);
1040         }
1041
1042       f->value.function.name = PREFIX("pack_s");
1043     }
1044 }
1045
1046
1047 void
1048 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1049                      gfc_expr * mask)
1050 {
1051   f->ts = array->ts;
1052
1053   if (dim != NULL)
1054     {
1055       f->rank = array->rank - 1;
1056       gfc_resolve_index (dim, 1);
1057     }
1058
1059   f->value.function.name =
1060     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1061                     gfc_type_letter (array->ts.type), array->ts.kind);
1062 }
1063
1064
1065 void
1066 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1067 {
1068   f->ts.type = BT_REAL;
1069
1070   if (kind != NULL)
1071     f->ts.kind = mpz_get_si (kind->value.integer);
1072   else
1073     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1074       a->ts.kind : gfc_default_real_kind;
1075
1076   f->value.function.name =
1077     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1078                     gfc_type_letter (a->ts.type), a->ts.kind);
1079 }
1080
1081
1082 void
1083 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1084                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1085 {
1086   f->ts.type = BT_CHARACTER;
1087   f->ts.kind = string->ts.kind;
1088   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1089 }
1090
1091
1092 void
1093 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1094                      gfc_expr * pad ATTRIBUTE_UNUSED,
1095                      gfc_expr * order ATTRIBUTE_UNUSED)
1096 {
1097   mpz_t rank;
1098   int kind;
1099   int i;
1100
1101   f->ts = source->ts;
1102
1103   gfc_array_size (shape, &rank);
1104   f->rank = mpz_get_si (rank);
1105   mpz_clear (rank);
1106   switch (source->ts.type)
1107     {
1108     case BT_COMPLEX:
1109       kind = source->ts.kind * 2;
1110       break;
1111
1112     case BT_REAL:
1113     case BT_INTEGER:
1114     case BT_LOGICAL:
1115       kind = source->ts.kind;
1116       break;
1117
1118     default:
1119       kind = 0;
1120       break;
1121     }
1122
1123   switch (kind)
1124     {
1125     case 4:
1126     case 8:
1127     /* case 16: */
1128       f->value.function.name =
1129         gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1130       break;
1131
1132     default:
1133       f->value.function.name = PREFIX("reshape");
1134       break;
1135     }
1136
1137   /* TODO: Make this work with a constant ORDER parameter.  */
1138   if (shape->expr_type == EXPR_ARRAY
1139       && gfc_is_constant_expr (shape)
1140       && order == NULL)
1141     {
1142       gfc_constructor *c;
1143       f->shape = gfc_get_shape (f->rank);
1144       c = shape->value.constructor;
1145       for (i = 0; i < f->rank; i++)
1146         {
1147           mpz_init_set (f->shape[i], c->expr->value.integer);
1148           c = c->next;
1149         }
1150     }
1151
1152   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1153      so many runtime variations.  */
1154   if (shape->ts.kind != gfc_index_integer_kind)
1155     {
1156       gfc_typespec ts = shape->ts;
1157       ts.kind = gfc_index_integer_kind;
1158       gfc_convert_type_warn (shape, &ts, 2, 0);
1159     }
1160   if (order && order->ts.kind != gfc_index_integer_kind)
1161     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1162 }
1163
1164
1165 void
1166 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1167 {
1168   f->ts = x->ts;
1169   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1170 }
1171
1172
1173 void
1174 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1175 {
1176   f->ts = x->ts;
1177
1178   /* The implementation calls scalbn which takes an int as the
1179      second argument.  */
1180   if (i->ts.kind != gfc_c_int_kind)
1181     {
1182       gfc_typespec ts;
1183
1184       ts.type = BT_INTEGER;
1185       ts.kind = gfc_default_integer_kind;
1186
1187       gfc_convert_type_warn (i, &ts, 2, 0);
1188     }
1189
1190   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1191 }
1192
1193
1194 void
1195 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1196                   gfc_expr * set ATTRIBUTE_UNUSED,
1197                   gfc_expr * back ATTRIBUTE_UNUSED)
1198 {
1199   f->ts.type = BT_INTEGER;
1200   f->ts.kind = gfc_default_integer_kind;
1201   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1202 }
1203
1204
1205 void
1206 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1207 {
1208   f->ts = x->ts;
1209
1210   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1211      convert type so we don't have to implment all possible
1212      permutations.  */
1213   if (i->ts.kind != 4)
1214     {
1215       gfc_typespec ts;
1216
1217       ts.type = BT_INTEGER;
1218       ts.kind = gfc_default_integer_kind;
1219
1220       gfc_convert_type_warn (i, &ts, 2, 0);
1221     }
1222
1223   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1224 }
1225
1226
1227 void
1228 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1229 {
1230   f->ts.type = BT_INTEGER;
1231   f->ts.kind = gfc_default_integer_kind;
1232   f->rank = 1;
1233   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1234   f->shape = gfc_get_shape (1);
1235   mpz_init_set_ui (f->shape[0], array->rank);
1236 }
1237
1238
1239 void
1240 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1241 {
1242   f->ts = a->ts;
1243   f->value.function.name =
1244     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1245 }
1246
1247
1248 void
1249 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1250 {
1251   f->ts = x->ts;
1252   f->value.function.name =
1253     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1254 }
1255
1256
1257 void
1258 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1259 {
1260   f->ts = x->ts;
1261   f->value.function.name =
1262     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1263 }
1264
1265
1266 void
1267 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1268 {
1269   f->ts = x->ts;
1270   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1271 }
1272
1273
1274 void
1275 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1276                     gfc_expr * dim,
1277                     gfc_expr * ncopies)
1278 {
1279   f->ts = source->ts;
1280   f->rank = source->rank + 1;
1281   f->value.function.name = PREFIX("spread");
1282
1283   gfc_resolve_index (dim, 1);
1284   gfc_resolve_index (ncopies, 1);
1285 }
1286
1287
1288 void
1289 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1290 {
1291   f->ts = x->ts;
1292   f->value.function.name =
1293     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1294 }
1295
1296
1297 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1298
1299 void
1300 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1301                   gfc_expr * a ATTRIBUTE_UNUSED)
1302 {
1303   f->ts.type = BT_INTEGER;
1304   f->ts.kind = gfc_default_integer_kind;
1305   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1306 }
1307
1308
1309 void
1310 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1311 {
1312   f->ts.type = BT_INTEGER;
1313   f->ts.kind = gfc_default_integer_kind;
1314   if (n->ts.kind != f->ts.kind)
1315     gfc_convert_type (n, &f->ts, 2);
1316
1317   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1318 }
1319
1320
1321 void
1322 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1323                  gfc_expr * mask)
1324 {
1325   f->ts = array->ts;
1326
1327   if (dim != NULL)
1328     {
1329       f->rank = array->rank - 1;
1330       gfc_resolve_index (dim, 1);
1331     }
1332
1333   f->value.function.name =
1334     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1335                     gfc_type_letter (array->ts.type), array->ts.kind);
1336 }
1337
1338
1339 /* Resolve the g77 compatibility function SYSTEM.  */
1340
1341 void
1342 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1343 {
1344   f->ts.type = BT_INTEGER;
1345   f->ts.kind = 4;
1346   f->value.function.name = gfc_get_string (PREFIX("system"));
1347 }
1348
1349
1350 void
1351 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1352 {
1353   f->ts = x->ts;
1354   f->value.function.name =
1355     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1356 }
1357
1358
1359 void
1360 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1361 {
1362   f->ts = x->ts;
1363   f->value.function.name =
1364     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1365 }
1366
1367
1368 void
1369 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1370                       gfc_expr * mold, gfc_expr * size)
1371 {
1372   /* TODO: Make this do something meaningful.  */
1373   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1374
1375   f->ts = mold->ts;
1376
1377   if (size == NULL && mold->rank == 0)
1378     {
1379       f->rank = 0;
1380       f->value.function.name = transfer0;
1381     }
1382   else
1383     {
1384       f->rank = 1;
1385       f->value.function.name = transfer1;
1386     }
1387 }
1388
1389
1390 void
1391 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1392 {
1393   int kind;
1394
1395   f->ts = matrix->ts;
1396   f->rank = 2;
1397   if (matrix->shape)
1398     {
1399       f->shape = gfc_get_shape (2);
1400       mpz_init_set (f->shape[0], matrix->shape[1]);
1401       mpz_init_set (f->shape[1], matrix->shape[0]);
1402     }
1403
1404   switch (matrix->ts.type)
1405     {
1406     case BT_COMPLEX:
1407       kind = matrix->ts.kind * 2;
1408       break;
1409
1410     case BT_REAL:
1411     case BT_INTEGER:
1412     case BT_LOGICAL:
1413       kind = matrix->ts.kind;
1414       break;
1415
1416     default:
1417       kind = 0;
1418       break;
1419
1420     }
1421
1422   switch (kind)
1423     {
1424     case 4:
1425     case 8:
1426     /* case 16: */
1427       f->value.function.name =
1428         gfc_get_string (PREFIX("transpose_%d"), kind);
1429       break;
1430
1431     default:
1432       f->value.function.name = PREFIX("transpose");
1433     }
1434 }
1435
1436
1437 void
1438 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1439 {
1440   f->ts.type = BT_CHARACTER;
1441   f->ts.kind = string->ts.kind;
1442   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1443 }
1444
1445
1446 void
1447 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1448                     gfc_expr * dim)
1449 {
1450   static char ubound[] = "__ubound";
1451
1452   f->ts.type = BT_INTEGER;
1453   f->ts.kind = gfc_default_integer_kind;
1454
1455   if (dim == NULL)
1456     {
1457       f->rank = 1;
1458       f->shape = gfc_get_shape (1);
1459       mpz_init_set_ui (f->shape[0], array->rank);
1460     }
1461
1462   f->value.function.name = ubound;
1463 }
1464
1465
1466 /* Resolve the g77 compatibility function UMASK.  */
1467
1468 void
1469 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1470 {
1471   f->ts.type = BT_INTEGER;
1472   f->ts.kind = n->ts.kind;
1473   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1474 }
1475
1476
1477 /* Resolve the g77 compatibility function UNLINK.  */
1478
1479 void
1480 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1481 {
1482   f->ts.type = BT_INTEGER;
1483   f->ts.kind = 4;
1484   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1485 }
1486
1487 void
1488 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1489                     gfc_expr * field ATTRIBUTE_UNUSED)
1490 {
1491   f->ts.type = vector->ts.type;
1492   f->ts.kind = vector->ts.kind;
1493   f->rank = mask->rank;
1494
1495   f->value.function.name =
1496     gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1497 }
1498
1499
1500 void
1501 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1502                     gfc_expr * set ATTRIBUTE_UNUSED,
1503                     gfc_expr * back ATTRIBUTE_UNUSED)
1504 {
1505   f->ts.type = BT_INTEGER;
1506   f->ts.kind = gfc_default_integer_kind;
1507   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1508 }
1509
1510
1511 /* Intrinsic subroutine resolution.  */
1512
1513 void
1514 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1515 {
1516   const char *name;
1517
1518   name = gfc_get_string (PREFIX("cpu_time_%d"),
1519                          c->ext.actual->expr->ts.kind);
1520   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1521 }
1522
1523
1524 void
1525 gfc_resolve_mvbits (gfc_code * c)
1526 {
1527   const char *name;
1528   int kind;
1529
1530   kind = c->ext.actual->expr->ts.kind;
1531   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1532
1533   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1534 }
1535
1536
1537 void
1538 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1539 {
1540   const char *name;
1541   int kind;
1542
1543   kind = c->ext.actual->expr->ts.kind;
1544   if (c->ext.actual->expr->rank == 0)
1545     name = gfc_get_string (PREFIX("random_r%d"), kind);
1546   else
1547     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1548   
1549   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1550 }
1551
1552
1553 /* G77 compatibility subroutines etime() and dtime().  */
1554
1555 void
1556 gfc_resolve_etime_sub (gfc_code * c)
1557 {
1558   const char *name;
1559
1560   name = gfc_get_string (PREFIX("etime_sub"));
1561   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1562 }
1563
1564
1565 /* G77 compatibility subroutine second().  */
1566
1567 void
1568 gfc_resolve_second_sub (gfc_code * c)
1569 {
1570   const char *name;
1571
1572   name = gfc_get_string (PREFIX("second_sub"));
1573   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1574 }
1575
1576
1577 /* G77 compatibility function srand().  */
1578
1579 void
1580 gfc_resolve_srand (gfc_code * c)
1581 {
1582   const char *name;
1583   name = gfc_get_string (PREFIX("srand"));
1584   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1585 }
1586
1587
1588 /* Resolve the getarg intrinsic subroutine.  */
1589
1590 void
1591 gfc_resolve_getarg (gfc_code * c)
1592 {
1593   const char *name;
1594   int kind;
1595
1596   kind = gfc_default_integer_kind;
1597   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1598   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1599 }
1600
1601 /* Resolve the getcwd intrinsic subroutine.  */
1602
1603 void
1604 gfc_resolve_getcwd_sub (gfc_code * c)
1605 {
1606   const char *name;
1607   int kind;
1608
1609   if (c->ext.actual->next->expr != NULL)
1610     kind = c->ext.actual->next->expr->ts.kind;
1611   else
1612     kind = gfc_default_integer_kind;
1613
1614   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1615   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1616 }
1617
1618
1619 /* Resolve the get_command intrinsic subroutine.  */
1620
1621 void
1622 gfc_resolve_get_command (gfc_code * c)
1623 {
1624   const char *name;
1625   int kind;
1626
1627   kind = gfc_default_integer_kind;
1628   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1629   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1630 }
1631
1632
1633 /* Resolve the get_command_argument intrinsic subroutine.  */
1634
1635 void
1636 gfc_resolve_get_command_argument (gfc_code * c)
1637 {
1638   const char *name;
1639   int kind;
1640
1641   kind = gfc_default_integer_kind;
1642   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1643   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1644 }
1645
1646 /* Resolve the get_environment_variable intrinsic subroutine.  */
1647
1648 void
1649 gfc_resolve_get_environment_variable (gfc_code * code)
1650 {
1651   const char *name;
1652   int kind;
1653
1654   kind = gfc_default_integer_kind;
1655   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1656   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1657 }
1658
1659 /* Resolve the SYSTEM intrinsic subroutine.  */
1660
1661 void
1662 gfc_resolve_system_sub (gfc_code * c)
1663 {
1664   const char *name;
1665
1666   name = gfc_get_string (PREFIX("system_sub"));
1667   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1668 }
1669
1670 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1671
1672 void
1673 gfc_resolve_system_clock (gfc_code * c)
1674 {
1675   const char *name;
1676   int kind;
1677
1678   if (c->ext.actual->expr != NULL)
1679     kind = c->ext.actual->expr->ts.kind;
1680   else if (c->ext.actual->next->expr != NULL)
1681       kind = c->ext.actual->next->expr->ts.kind;
1682   else if (c->ext.actual->next->next->expr != NULL)
1683       kind = c->ext.actual->next->next->expr->ts.kind;
1684   else
1685     kind = gfc_default_integer_kind;
1686
1687   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1688   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1689 }
1690
1691 /* Resolve the EXIT intrinsic subroutine.  */
1692
1693 void
1694 gfc_resolve_exit (gfc_code * c)
1695 {
1696   const char *name;
1697   int kind;
1698
1699   if (c->ext.actual->expr != NULL)
1700     kind = c->ext.actual->expr->ts.kind;
1701   else
1702     kind = gfc_default_integer_kind;
1703
1704   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1705   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1706 }
1707
1708 /* Resolve the FLUSH intrinsic subroutine.  */
1709
1710 void
1711 gfc_resolve_flush (gfc_code * c)
1712 {
1713   const char *name;
1714   gfc_typespec ts;
1715   gfc_expr *n;
1716
1717   ts.type = BT_INTEGER;
1718   ts.kind = gfc_default_integer_kind;
1719   n = c->ext.actual->expr;
1720   if (n != NULL
1721       && n->ts.kind != ts.kind)
1722     gfc_convert_type (n, &ts, 2);
1723
1724   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1725   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1726 }
1727
1728 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1729
1730 void
1731 gfc_resolve_stat_sub (gfc_code * c)
1732 {
1733   const char *name;
1734
1735   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1736   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1737 }
1738
1739
1740 void
1741 gfc_resolve_fstat_sub (gfc_code * c)
1742 {
1743   const char *name;
1744   gfc_expr *u;
1745   gfc_typespec *ts;
1746
1747   u = c->ext.actual->expr;
1748   ts = &c->ext.actual->next->expr->ts;
1749   if (u->ts.kind != ts->kind)
1750     gfc_convert_type (u, ts, 2);
1751   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1752   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1753 }
1754
1755 /* Resolve the UMASK intrinsic subroutine.  */
1756
1757 void
1758 gfc_resolve_umask_sub (gfc_code * c)
1759 {
1760   const char *name;
1761   int kind;
1762
1763   if (c->ext.actual->next->expr != NULL)
1764     kind = c->ext.actual->next->expr->ts.kind;
1765   else
1766     kind = gfc_default_integer_kind;
1767
1768   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1769   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1770 }
1771
1772 /* Resolve the UNLINK intrinsic subroutine.  */
1773
1774 void
1775 gfc_resolve_unlink_sub (gfc_code * c)
1776 {
1777   const char *name;
1778   int kind;
1779
1780   if (c->ext.actual->next->expr != NULL)
1781     kind = c->ext.actual->next->expr->ts.kind;
1782   else
1783     kind = gfc_default_integer_kind;
1784
1785   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
1786   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1787 }
1788
1789
1790 void
1791 gfc_iresolve_init_1 (void)
1792 {
1793   int i;
1794
1795   for (i = 0; i < HASH_SIZE; i++)
1796     string_head[i] = NULL;
1797 }
1798
1799
1800 void
1801 gfc_iresolve_done_1 (void)
1802 {
1803   free_strings ();
1804 }