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