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