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