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