]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/iresolve.c
projects / thirdparty / gcc.git / blob
? search:


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