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