OSDN Git Service

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