?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
re PR testsuite/40567 (Revision 149002 caused many failures)
[official-gcc.git] / gcc / fortran / iresolve.c
blob619d7e9546af0a004d32cf1546c0ab62afb4e603
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 && mask->ts.kind != 1)
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.op = 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.op = 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 if (a->rank == 2 && b->rank == 2)
1345 {
1346 if (a->shape && b->shape)
1347 {
1348 f->shape = gfc_get_shape (f->rank);
1349 mpz_init_set (f->shape[0], a->shape[0]);
1350 mpz_init_set (f->shape[1], b->shape[1]);
1351 }
1352 }
1353 else if (a->rank == 1)
1354 {
1355 if (b->shape)
1356 {
1357 f->shape = gfc_get_shape (f->rank);
1358 mpz_init_set (f->shape[0], b->shape[1]);
1359 }
1360 }
1361 else
1362 {
1363 /* b->rank == 1 and a->rank == 2 here, all other cases have
1364 been caught in check.c. */
1365 if (a->shape)
1366 {
1367 f->shape = gfc_get_shape (f->rank);
1368 mpz_init_set (f->shape[0], a->shape[0]);
1369 }
1370 }
1371
1372 f->value.function.name
1373 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1374 f->ts.kind);
1375 }
1376
1377
1378 static void
1379 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1380 {
1381 gfc_actual_arglist *a;
1382
1383 f->ts.type = args->expr->ts.type;
1384 f->ts.kind = args->expr->ts.kind;
1385 /* Find the largest type kind. */
1386 for (a = args->next; a; a = a->next)
1387 {
1388 if (a->expr->ts.kind > f->ts.kind)
1389 f->ts.kind = a->expr->ts.kind;
1390 }
1391
1392 /* Convert all parameters to the required kind. */
1393 for (a = args; a; a = a->next)
1394 {
1395 if (a->expr->ts.kind != f->ts.kind)
1396 gfc_convert_type (a->expr, &f->ts, 2);
1397 }
1398
1399 f->value.function.name
1400 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1401 }
1402
1403
1404 void
1405 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1406 {
1407 gfc_resolve_minmax ("__max_%c%d", f, args);
1408 }
1409
1410
1411 void
1412 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1413 gfc_expr *mask)
1414 {
1415 const char *name;
1416 int i, j, idim;
1417
1418 f->ts.type = BT_INTEGER;
1419 f->ts.kind = gfc_default_integer_kind;
1420
1421 if (dim == NULL)
1422 {
1423 f->rank = 1;
1424 f->shape = gfc_get_shape (1);
1425 mpz_init_set_si (f->shape[0], array->rank);
1426 }
1427 else
1428 {
1429 f->rank = array->rank - 1;
1430 gfc_resolve_dim_arg (dim);
1431 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1432 {
1433 idim = (int) mpz_get_si (dim->value.integer);
1434 f->shape = gfc_get_shape (f->rank);
1435 for (i = 0, j = 0; i < f->rank; i++, j++)
1436 {
1437 if (i == (idim - 1))
1438 j++;
1439 mpz_init_set (f->shape[i], array->shape[j]);
1440 }
1441 }
1442 }
1443
1444 if (mask)
1445 {
1446 if (mask->rank == 0)
1447 name = "smaxloc";
1448 else
1449 name = "mmaxloc";
1450
1451 resolve_mask_arg (mask);
1452 }
1453 else
1454 name = "maxloc";
1455
1456 f->value.function.name
1457 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1458 gfc_type_letter (array->ts.type), array->ts.kind);
1459 }
1460
1461
1462 void
1463 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1464 gfc_expr *mask)
1465 {
1466 const char *name;
1467 int i, j, idim;
1468
1469 f->ts = array->ts;
1470
1471 if (dim != NULL)
1472 {
1473 f->rank = array->rank - 1;
1474 gfc_resolve_dim_arg (dim);
1475
1476 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1477 {
1478 idim = (int) mpz_get_si (dim->value.integer);
1479 f->shape = gfc_get_shape (f->rank);
1480 for (i = 0, j = 0; i < f->rank; i++, j++)
1481 {
1482 if (i == (idim - 1))
1483 j++;
1484 mpz_init_set (f->shape[i], array->shape[j]);
1485 }
1486 }
1487 }
1488
1489 if (mask)
1490 {
1491 if (mask->rank == 0)
1492 name = "smaxval";
1493 else
1494 name = "mmaxval";
1495
1496 resolve_mask_arg (mask);
1497 }
1498 else
1499 name = "maxval";
1500
1501 f->value.function.name
1502 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1503 gfc_type_letter (array->ts.type), array->ts.kind);
1504 }
1505
1506
1507 void
1508 gfc_resolve_mclock (gfc_expr *f)
1509 {
1510 f->ts.type = BT_INTEGER;
1511 f->ts.kind = 4;
1512 f->value.function.name = PREFIX ("mclock");
1513 }
1514
1515
1516 void
1517 gfc_resolve_mclock8 (gfc_expr *f)
1518 {
1519 f->ts.type = BT_INTEGER;
1520 f->ts.kind = 8;
1521 f->value.function.name = PREFIX ("mclock8");
1522 }
1523
1524
1525 void
1526 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1527 gfc_expr *fsource ATTRIBUTE_UNUSED,
1528 gfc_expr *mask ATTRIBUTE_UNUSED)
1529 {
1530 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1531 gfc_resolve_substring_charlen (tsource);
1532
1533 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1534 gfc_resolve_substring_charlen (fsource);
1535
1536 if (tsource->ts.type == BT_CHARACTER)
1537 check_charlen_present (tsource);
1538
1539 f->ts = tsource->ts;
1540 f->value.function.name
1541 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1542 tsource->ts.kind);
1543 }
1544
1545
1546 void
1547 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1548 {
1549 gfc_resolve_minmax ("__min_%c%d", f, args);
1550 }
1551
1552
1553 void
1554 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1555 gfc_expr *mask)
1556 {
1557 const char *name;
1558 int i, j, idim;
1559
1560 f->ts.type = BT_INTEGER;
1561 f->ts.kind = gfc_default_integer_kind;
1562
1563 if (dim == NULL)
1564 {
1565 f->rank = 1;
1566 f->shape = gfc_get_shape (1);
1567 mpz_init_set_si (f->shape[0], array->rank);
1568 }
1569 else
1570 {
1571 f->rank = array->rank - 1;
1572 gfc_resolve_dim_arg (dim);
1573 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1574 {
1575 idim = (int) mpz_get_si (dim->value.integer);
1576 f->shape = gfc_get_shape (f->rank);
1577 for (i = 0, j = 0; i < f->rank; i++, j++)
1578 {
1579 if (i == (idim - 1))
1580 j++;
1581 mpz_init_set (f->shape[i], array->shape[j]);
1582 }
1583 }
1584 }
1585
1586 if (mask)
1587 {
1588 if (mask->rank == 0)
1589 name = "sminloc";
1590 else
1591 name = "mminloc";
1592
1593 resolve_mask_arg (mask);
1594 }
1595 else
1596 name = "minloc";
1597
1598 f->value.function.name
1599 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1600 gfc_type_letter (array->ts.type), array->ts.kind);
1601 }
1602
1603
1604 void
1605 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1606 gfc_expr *mask)
1607 {
1608 const char *name;
1609 int i, j, idim;
1610
1611 f->ts = array->ts;
1612
1613 if (dim != NULL)
1614 {
1615 f->rank = array->rank - 1;
1616 gfc_resolve_dim_arg (dim);
1617
1618 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1619 {
1620 idim = (int) mpz_get_si (dim->value.integer);
1621 f->shape = gfc_get_shape (f->rank);
1622 for (i = 0, j = 0; i < f->rank; i++, j++)
1623 {
1624 if (i == (idim - 1))
1625 j++;
1626 mpz_init_set (f->shape[i], array->shape[j]);
1627 }
1628 }
1629 }
1630
1631 if (mask)
1632 {
1633 if (mask->rank == 0)
1634 name = "sminval";
1635 else
1636 name = "mminval";
1637
1638 resolve_mask_arg (mask);
1639 }
1640 else
1641 name = "minval";
1642
1643 f->value.function.name
1644 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1645 gfc_type_letter (array->ts.type), array->ts.kind);
1646 }
1647
1648
1649 void
1650 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1651 {
1652 f->ts.type = a->ts.type;
1653 if (p != NULL)
1654 f->ts.kind = gfc_kind_max (a,p);
1655 else
1656 f->ts.kind = a->ts.kind;
1657
1658 if (p != NULL && a->ts.kind != p->ts.kind)
1659 {
1660 if (a->ts.kind == gfc_kind_max (a,p))
1661 gfc_convert_type (p, &a->ts, 2);
1662 else
1663 gfc_convert_type (a, &p->ts, 2);
1664 }
1665
1666 f->value.function.name
1667 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1668 }
1669
1670
1671 void
1672 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1673 {
1674 f->ts.type = a->ts.type;
1675 if (p != NULL)
1676 f->ts.kind = gfc_kind_max (a,p);
1677 else
1678 f->ts.kind = a->ts.kind;
1679
1680 if (p != NULL && a->ts.kind != p->ts.kind)
1681 {
1682 if (a->ts.kind == gfc_kind_max (a,p))
1683 gfc_convert_type (p, &a->ts, 2);
1684 else
1685 gfc_convert_type (a, &p->ts, 2);
1686 }
1687
1688 f->value.function.name
1689 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1690 f->ts.kind);
1691 }
1692
1693 void
1694 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1695 {
1696 if (p->ts.kind != a->ts.kind)
1697 gfc_convert_type (p, &a->ts, 2);
1698
1699 f->ts = a->ts;
1700 f->value.function.name
1701 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1702 a->ts.kind);
1703 }
1704
1705 void
1706 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1707 {
1708 f->ts.type = BT_INTEGER;
1709 f->ts.kind = (kind == NULL)
1710 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1711 f->value.function.name
1712 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1713 }
1714
1715
1716 void
1717 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1718 {
1719 f->ts = i->ts;
1720 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1721 }
1722
1723
1724 void
1725 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1726 {
1727 f->ts.type = i->ts.type;
1728 f->ts.kind = gfc_kind_max (i, j);
1729
1730 if (i->ts.kind != j->ts.kind)
1731 {
1732 if (i->ts.kind == gfc_kind_max (i, j))
1733 gfc_convert_type (j, &i->ts, 2);
1734 else
1735 gfc_convert_type (i, &j->ts, 2);
1736 }
1737
1738 f->value.function.name
1739 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1740 }
1741
1742
1743 void
1744 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1745 gfc_expr *vector ATTRIBUTE_UNUSED)
1746 {
1747 if (array->ts.type == BT_CHARACTER && array->ref)
1748 gfc_resolve_substring_charlen (array);
1749
1750 f->ts = array->ts;
1751 f->rank = 1;
1752
1753 resolve_mask_arg (mask);
1754
1755 if (mask->rank != 0)
1756 {
1757 if (array->ts.type == BT_CHARACTER)
1758 f->value.function.name
1759 = array->ts.kind == 1 ? PREFIX ("pack_char")
1760 : gfc_get_string
1761 (PREFIX ("pack_char%d"),
1762 array->ts.kind);
1763 else
1764 f->value.function.name = PREFIX ("pack");
1765 }
1766 else
1767 {
1768 if (array->ts.type == BT_CHARACTER)
1769 f->value.function.name
1770 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1771 : gfc_get_string
1772 (PREFIX ("pack_s_char%d"),
1773 array->ts.kind);
1774 else
1775 f->value.function.name = PREFIX ("pack_s");
1776 }
1777 }
1778
1779
1780 void
1781 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1782 gfc_expr *mask)
1783 {
1784 const char *name;
1785
1786 f->ts = array->ts;
1787
1788 if (dim != NULL)
1789 {
1790 f->rank = array->rank - 1;
1791 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1792 gfc_resolve_dim_arg (dim);
1793 }
1794
1795 if (mask)
1796 {
1797 if (mask->rank == 0)
1798 name = "sproduct";
1799 else
1800 name = "mproduct";
1801
1802 resolve_mask_arg (mask);
1803 }
1804 else
1805 name = "product";
1806
1807 f->value.function.name
1808 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1809 gfc_type_letter (array->ts.type), array->ts.kind);
1810 }
1811
1812
1813 void
1814 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1815 {
1816 f->ts.type = BT_REAL;
1817
1818 if (kind != NULL)
1819 f->ts.kind = mpz_get_si (kind->value.integer);
1820 else
1821 f->ts.kind = (a->ts.type == BT_COMPLEX)
1822 ? a->ts.kind : gfc_default_real_kind;
1823
1824 f->value.function.name
1825 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1826 gfc_type_letter (a->ts.type), a->ts.kind);
1827 }
1828
1829
1830 void
1831 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1832 {
1833 f->ts.type = BT_REAL;
1834 f->ts.kind = a->ts.kind;
1835 f->value.function.name
1836 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1837 gfc_type_letter (a->ts.type), a->ts.kind);
1838 }
1839
1840
1841 void
1842 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1843 gfc_expr *p2 ATTRIBUTE_UNUSED)
1844 {
1845 f->ts.type = BT_INTEGER;
1846 f->ts.kind = gfc_default_integer_kind;
1847 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1848 }
1849
1850
1851 void
1852 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1853 gfc_expr *ncopies ATTRIBUTE_UNUSED)
1854 {
1855 f->ts.type = BT_CHARACTER;
1856 f->ts.kind = string->ts.kind;
1857 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1858 }
1859
1860
1861 void
1862 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1863 gfc_expr *pad ATTRIBUTE_UNUSED,
1864 gfc_expr *order ATTRIBUTE_UNUSED)
1865 {
1866 mpz_t rank;
1867 int kind;
1868 int i;
1869
1870 if (source->ts.type == BT_CHARACTER && source->ref)
1871 gfc_resolve_substring_charlen (source);
1872
1873 f->ts = source->ts;
1874
1875 gfc_array_size (shape, &rank);
1876 f->rank = mpz_get_si (rank);
1877 mpz_clear (rank);
1878 switch (source->ts.type)
1879 {
1880 case BT_COMPLEX:
1881 case BT_REAL:
1882 case BT_INTEGER:
1883 case BT_LOGICAL:
1884 case BT_CHARACTER:
1885 kind = source->ts.kind;
1886 break;
1887
1888 default:
1889 kind = 0;
1890 break;
1891 }
1892
1893 switch (kind)
1894 {
1895 case 4:
1896 case 8:
1897 case 10:
1898 case 16:
1899 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1900 f->value.function.name
1901 = gfc_get_string (PREFIX ("reshape_%c%d"),
1902 gfc_type_letter (source->ts.type),
1903 source->ts.kind);
1904 else if (source->ts.type == BT_CHARACTER)
1905 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
1906 kind);
1907 else
1908 f->value.function.name
1909 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1910 break;
1911
1912 default:
1913 f->value.function.name = (source->ts.type == BT_CHARACTER
1914 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1915 break;
1916 }
1917
1918 /* TODO: Make this work with a constant ORDER parameter. */
1919 if (shape->expr_type == EXPR_ARRAY
1920 && gfc_is_constant_expr (shape)
1921 && order == NULL)
1922 {
1923 gfc_constructor *c;
1924 f->shape = gfc_get_shape (f->rank);
1925 c = shape->value.constructor;
1926 for (i = 0; i < f->rank; i++)
1927 {
1928 mpz_init_set (f->shape[i], c->expr->value.integer);
1929 c = c->next;
1930 }
1931 }
1932
1933 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1934 so many runtime variations. */
1935 if (shape->ts.kind != gfc_index_integer_kind)
1936 {
1937 gfc_typespec ts = shape->ts;
1938 ts.kind = gfc_index_integer_kind;
1939 gfc_convert_type_warn (shape, &ts, 2, 0);
1940 }
1941 if (order && order->ts.kind != gfc_index_integer_kind)
1942 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1943 }
1944
1945
1946 void
1947 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1948 {
1949 f->ts = x->ts;
1950 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1951 }
1952
1953
1954 void
1955 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
1956 {
1957 f->ts = x->ts;
1958 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1959 }
1960
1961
1962 void
1963 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
1964 gfc_expr *set ATTRIBUTE_UNUSED,
1965 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
1966 {
1967 f->ts.type = BT_INTEGER;
1968 if (kind)
1969 f->ts.kind = mpz_get_si (kind->value.integer);
1970 else
1971 f->ts.kind = gfc_default_integer_kind;
1972 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1973 }
1974
1975
1976 void
1977 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
1978 {
1979 t1->ts = t0->ts;
1980 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
1981 }
1982
1983
1984 void
1985 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
1986 gfc_expr *i ATTRIBUTE_UNUSED)
1987 {
1988 f->ts = x->ts;
1989 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1990 }
1991
1992
1993 void
1994 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
1995 {
1996 f->ts.type = BT_INTEGER;
1997 f->ts.kind = gfc_default_integer_kind;
1998 f->rank = 1;
1999 f->shape = gfc_get_shape (1);
2000 mpz_init_set_ui (f->shape[0], array->rank);
2001 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2002 }
2003
2004
2005 void
2006 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2007 {
2008 f->ts = a->ts;
2009 f->value.function.name
2010 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2011 }
2012
2013
2014 void
2015 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2016 {
2017 f->ts.type = BT_INTEGER;
2018 f->ts.kind = gfc_c_int_kind;
2019
2020 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2021 if (handler->ts.type == BT_INTEGER)
2022 {
2023 if (handler->ts.kind != gfc_c_int_kind)
2024 gfc_convert_type (handler, &f->ts, 2);
2025 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2026 }
2027 else
2028 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2029
2030 if (number->ts.kind != gfc_c_int_kind)
2031 gfc_convert_type (number, &f->ts, 2);
2032 }
2033
2034
2035 void
2036 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2037 {
2038 f->ts = x->ts;
2039 f->value.function.name
2040 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2041 }
2042
2043
2044 void
2045 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2046 {
2047 f->ts = x->ts;
2048 f->value.function.name
2049 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2050 }
2051
2052
2053 void
2054 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2055 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2056 {
2057 f->ts.type = BT_INTEGER;
2058 if (kind)
2059 f->ts.kind = mpz_get_si (kind->value.integer);
2060 else
2061 f->ts.kind = gfc_default_integer_kind;
2062 }
2063
2064
2065 void
2066 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2067 {
2068 f->ts = x->ts;
2069 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2070 }
2071
2072
2073 void
2074 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2075 gfc_expr *ncopies)
2076 {
2077 if (source->ts.type == BT_CHARACTER && source->ref)
2078 gfc_resolve_substring_charlen (source);
2079
2080 if (source->ts.type == BT_CHARACTER)
2081 check_charlen_present (source);
2082
2083 f->ts = source->ts;
2084 f->rank = source->rank + 1;
2085 if (source->rank == 0)
2086 {
2087 if (source->ts.type == BT_CHARACTER)
2088 f->value.function.name
2089 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2090 : gfc_get_string
2091 (PREFIX ("spread_char%d_scalar"),
2092 source->ts.kind);
2093 else
2094 f->value.function.name = PREFIX ("spread_scalar");
2095 }
2096 else
2097 {
2098 if (source->ts.type == BT_CHARACTER)
2099 f->value.function.name
2100 = source->ts.kind == 1 ? PREFIX ("spread_char")
2101 : gfc_get_string
2102 (PREFIX ("spread_char%d"),
2103 source->ts.kind);
2104 else
2105 f->value.function.name = PREFIX ("spread");
2106 }
2107
2108 if (dim && gfc_is_constant_expr (dim)
2109 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2110 {
2111 int i, idim;
2112 idim = mpz_get_ui (dim->value.integer);
2113 f->shape = gfc_get_shape (f->rank);
2114 for (i = 0; i < (idim - 1); i++)
2115 mpz_init_set (f->shape[i], source->shape[i]);
2116
2117 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2118
2119 for (i = idim; i < f->rank ; i++)
2120 mpz_init_set (f->shape[i], source->shape[i-1]);
2121 }
2122
2123
2124 gfc_resolve_dim_arg (dim);
2125 gfc_resolve_index (ncopies, 1);
2126 }
2127
2128
2129 void
2130 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2131 {
2132 f->ts = x->ts;
2133 f->value.function.name
2134 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2135 }
2136
2137
2138 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2139
2140 void
2141 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2142 gfc_expr *a ATTRIBUTE_UNUSED)
2143 {
2144 f->ts.type = BT_INTEGER;
2145 f->ts.kind = gfc_default_integer_kind;
2146 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2147 }
2148
2149
2150 void
2151 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2152 gfc_expr *a ATTRIBUTE_UNUSED)
2153 {
2154 f->ts.type = BT_INTEGER;
2155 f->ts.kind = gfc_default_integer_kind;
2156 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2157 }
2158
2159
2160 void
2161 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2162 {
2163 f->ts.type = BT_INTEGER;
2164 f->ts.kind = gfc_default_integer_kind;
2165 if (n->ts.kind != f->ts.kind)
2166 gfc_convert_type (n, &f->ts, 2);
2167
2168 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2169 }
2170
2171
2172 void
2173 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2174 {
2175 gfc_typespec ts;
2176 gfc_clear_ts (&ts);
2177
2178 f->ts.type = BT_INTEGER;
2179 f->ts.kind = gfc_c_int_kind;
2180 if (u->ts.kind != gfc_c_int_kind)
2181 {
2182 ts.type = BT_INTEGER;
2183 ts.kind = gfc_c_int_kind;
2184 ts.derived = NULL;
2185 ts.cl = NULL;
2186 gfc_convert_type (u, &ts, 2);
2187 }
2188
2189 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2190 }
2191
2192
2193 void
2194 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2195 {
2196 f->ts.type = BT_INTEGER;
2197 f->ts.kind = gfc_c_int_kind;
2198 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2199 }
2200
2201
2202 void
2203 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2204 {
2205 gfc_typespec ts;
2206 gfc_clear_ts (&ts);
2207
2208 f->ts.type = BT_INTEGER;
2209 f->ts.kind = gfc_c_int_kind;
2210 if (u->ts.kind != gfc_c_int_kind)
2211 {
2212 ts.type = BT_INTEGER;
2213 ts.kind = gfc_c_int_kind;
2214 ts.derived = NULL;
2215 ts.cl = NULL;
2216 gfc_convert_type (u, &ts, 2);
2217 }
2218
2219 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2220 }
2221
2222
2223 void
2224 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2225 {
2226 f->ts.type = BT_INTEGER;
2227 f->ts.kind = gfc_c_int_kind;
2228 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2229 }
2230
2231
2232 void
2233 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2234 {
2235 gfc_typespec ts;
2236 gfc_clear_ts (&ts);
2237
2238 f->ts.type = BT_INTEGER;
2239 f->ts.kind = gfc_index_integer_kind;
2240 if (u->ts.kind != gfc_c_int_kind)
2241 {
2242 ts.type = BT_INTEGER;
2243 ts.kind = gfc_c_int_kind;
2244 ts.derived = NULL;
2245 ts.cl = NULL;
2246 gfc_convert_type (u, &ts, 2);
2247 }
2248
2249 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2250 }
2251
2252
2253 void
2254 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2255 {
2256 const char *name;
2257
2258 f->ts = array->ts;
2259
2260 if (mask)
2261 {
2262 if (mask->rank == 0)
2263 name = "ssum";
2264 else
2265 name = "msum";
2266
2267 resolve_mask_arg (mask);
2268 }
2269 else
2270 name = "sum";
2271
2272 if (dim != NULL)
2273 {
2274 f->rank = array->rank - 1;
2275 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2276 gfc_resolve_dim_arg (dim);
2277 }
2278
2279 f->value.function.name
2280 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2281 gfc_type_letter (array->ts.type), array->ts.kind);
2282 }
2283
2284
2285 void
2286 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2287 gfc_expr *p2 ATTRIBUTE_UNUSED)
2288 {
2289 f->ts.type = BT_INTEGER;
2290 f->ts.kind = gfc_default_integer_kind;
2291 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2292 }
2293
2294
2295 /* Resolve the g77 compatibility function SYSTEM. */
2296
2297 void
2298 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2299 {
2300 f->ts.type = BT_INTEGER;
2301 f->ts.kind = 4;
2302 f->value.function.name = gfc_get_string (PREFIX ("system"));
2303 }
2304
2305
2306 void
2307 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2308 {
2309 f->ts = x->ts;
2310 f->value.function.name
2311 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2312 }
2313
2314
2315 void
2316 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2317 {
2318 f->ts = x->ts;
2319 f->value.function.name
2320 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2321 }
2322
2323
2324 void
2325 gfc_resolve_time (gfc_expr *f)
2326 {
2327 f->ts.type = BT_INTEGER;
2328 f->ts.kind = 4;
2329 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2330 }
2331
2332
2333 void
2334 gfc_resolve_time8 (gfc_expr *f)
2335 {
2336 f->ts.type = BT_INTEGER;
2337 f->ts.kind = 8;
2338 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2339 }
2340
2341
2342 void
2343 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2344 gfc_expr *mold, gfc_expr *size)
2345 {
2346 /* TODO: Make this do something meaningful. */
2347 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2348
2349 if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length
2350 && !(mold->expr_type == EXPR_VARIABLE && mold->symtree->n.sym->attr.dummy))
2351 mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
2352
2353 f->ts = mold->ts;
2354
2355 if (size == NULL && mold->rank == 0)
2356 {
2357 f->rank = 0;
2358 f->value.function.name = transfer0;
2359 }
2360 else
2361 {
2362 f->rank = 1;
2363 f->value.function.name = transfer1;
2364 if (size && gfc_is_constant_expr (size))
2365 {
2366 f->shape = gfc_get_shape (1);
2367 mpz_init_set (f->shape[0], size->value.integer);
2368 }
2369 }
2370 }
2371
2372
2373 void
2374 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2375 {
2376
2377 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2378 gfc_resolve_substring_charlen (matrix);
2379
2380 f->ts = matrix->ts;
2381 f->rank = 2;
2382 if (matrix->shape)
2383 {
2384 f->shape = gfc_get_shape (2);
2385 mpz_init_set (f->shape[0], matrix->shape[1]);
2386 mpz_init_set (f->shape[1], matrix->shape[0]);
2387 }
2388
2389 switch (matrix->ts.kind)
2390 {
2391 case 4:
2392 case 8:
2393 case 10:
2394 case 16:
2395 switch (matrix->ts.type)
2396 {
2397 case BT_REAL:
2398 case BT_COMPLEX:
2399 f->value.function.name
2400 = gfc_get_string (PREFIX ("transpose_%c%d"),
2401 gfc_type_letter (matrix->ts.type),
2402 matrix->ts.kind);
2403 break;
2404
2405 case BT_INTEGER:
2406 case BT_LOGICAL:
2407 /* Use the integer routines for real and logical cases. This
2408 assumes they all have the same alignment requirements. */
2409 f->value.function.name
2410 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2411 break;
2412
2413 default:
2414 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2415 f->value.function.name = PREFIX ("transpose_char4");
2416 else
2417 f->value.function.name = PREFIX ("transpose");
2418 break;
2419 }
2420 break;
2421
2422 default:
2423 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2424 ? PREFIX ("transpose_char")
2425 : PREFIX ("transpose"));
2426 break;
2427 }
2428 }
2429
2430
2431 void
2432 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2433 {
2434 f->ts.type = BT_CHARACTER;
2435 f->ts.kind = string->ts.kind;
2436 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2437 }
2438
2439
2440 void
2441 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2442 {
2443 static char ubound[] = "__ubound";
2444
2445 f->ts.type = BT_INTEGER;
2446 if (kind)
2447 f->ts.kind = mpz_get_si (kind->value.integer);
2448 else
2449 f->ts.kind = gfc_default_integer_kind;
2450
2451 if (dim == NULL)
2452 {
2453 f->rank = 1;
2454 f->shape = gfc_get_shape (1);
2455 mpz_init_set_ui (f->shape[0], array->rank);
2456 }
2457
2458 f->value.function.name = ubound;
2459 }
2460
2461
2462 /* Resolve the g77 compatibility function UMASK. */
2463
2464 void
2465 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2466 {
2467 f->ts.type = BT_INTEGER;
2468 f->ts.kind = n->ts.kind;
2469 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2470 }
2471
2472
2473 /* Resolve the g77 compatibility function UNLINK. */
2474
2475 void
2476 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2477 {
2478 f->ts.type = BT_INTEGER;
2479 f->ts.kind = 4;
2480 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2481 }
2482
2483
2484 void
2485 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2486 {
2487 gfc_typespec ts;
2488 gfc_clear_ts (&ts);
2489
2490 f->ts.type = BT_CHARACTER;
2491 f->ts.kind = gfc_default_character_kind;
2492
2493 if (unit->ts.kind != gfc_c_int_kind)
2494 {
2495 ts.type = BT_INTEGER;
2496 ts.kind = gfc_c_int_kind;
2497 ts.derived = NULL;
2498 ts.cl = NULL;
2499 gfc_convert_type (unit, &ts, 2);
2500 }
2501
2502 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2503 }
2504
2505
2506 void
2507 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2508 gfc_expr *field ATTRIBUTE_UNUSED)
2509 {
2510 if (vector->ts.type == BT_CHARACTER && vector->ref)
2511 gfc_resolve_substring_charlen (vector);
2512
2513 f->ts = vector->ts;
2514 f->rank = mask->rank;
2515 resolve_mask_arg (mask);
2516
2517 if (vector->ts.type == BT_CHARACTER)
2518 {
2519 if (vector->ts.kind == 1)
2520 f->value.function.name
2521 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2522 else
2523 f->value.function.name
2524 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2525 field->rank > 0 ? 1 : 0, vector->ts.kind);
2526 }
2527 else
2528 f->value.function.name
2529 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2530 }
2531
2532
2533 void
2534 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2535 gfc_expr *set ATTRIBUTE_UNUSED,
2536 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2537 {
2538 f->ts.type = BT_INTEGER;
2539 if (kind)
2540 f->ts.kind = mpz_get_si (kind->value.integer);
2541 else
2542 f->ts.kind = gfc_default_integer_kind;
2543 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2544 }
2545
2546
2547 void
2548 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2549 {
2550 f->ts.type = i->ts.type;
2551 f->ts.kind = gfc_kind_max (i, j);
2552
2553 if (i->ts.kind != j->ts.kind)
2554 {
2555 if (i->ts.kind == gfc_kind_max (i, j))
2556 gfc_convert_type (j, &i->ts, 2);
2557 else
2558 gfc_convert_type (i, &j->ts, 2);
2559 }
2560
2561 f->value.function.name
2562 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2563 }
2564
2565
2566 /* Intrinsic subroutine resolution. */
2567
2568 void
2569 gfc_resolve_alarm_sub (gfc_code *c)
2570 {
2571 const char *name;
2572 gfc_expr *seconds, *handler, *status;
2573 gfc_typespec ts;
2574 gfc_clear_ts (&ts);
2575
2576 seconds = c->ext.actual->expr;
2577 handler = c->ext.actual->next->expr;
2578 status = c->ext.actual->next->next->expr;
2579 ts.type = BT_INTEGER;
2580 ts.kind = gfc_c_int_kind;
2581
2582 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2583 In all cases, the status argument is of default integer kind
2584 (enforced in check.c) so that the function suffix is fixed. */
2585 if (handler->ts.type == BT_INTEGER)
2586 {
2587 if (handler->ts.kind != gfc_c_int_kind)
2588 gfc_convert_type (handler, &ts, 2);
2589 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2590 gfc_default_integer_kind);
2591 }
2592 else
2593 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2594 gfc_default_integer_kind);
2595
2596 if (seconds->ts.kind != gfc_c_int_kind)
2597 gfc_convert_type (seconds, &ts, 2);
2598
2599 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2600 }
2601
2602 void
2603 gfc_resolve_cpu_time (gfc_code *c)
2604 {
2605 const char *name;
2606 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2607 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2608 }
2609
2610
2611 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2612
2613 static gfc_formal_arglist*
2614 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2615 {
2616 gfc_formal_arglist* head;
2617 gfc_formal_arglist* tail;
2618 int i;
2619
2620 if (!actual)
2621 return NULL;
2622
2623 head = tail = gfc_get_formal_arglist ();
2624 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2625 {
2626 gfc_symbol* sym;
2627
2628 sym = gfc_new_symbol ("dummyarg", NULL);
2629 sym->ts = actual->expr->ts;
2630
2631 sym->attr.intent = ints[i];
2632 tail->sym = sym;
2633
2634 if (actual->next)
2635 tail->next = gfc_get_formal_arglist ();
2636 }
2637
2638 return head;
2639 }
2640
2641
2642 void
2643 gfc_resolve_mvbits (gfc_code *c)
2644 {
2645 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2646 INTENT_INOUT, INTENT_IN};
2647
2648 const char *name;
2649 gfc_typespec ts;
2650 gfc_clear_ts (&ts);
2651
2652 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2653 they will be converted so that they fit into a C int. */
2654 ts.type = BT_INTEGER;
2655 ts.kind = gfc_c_int_kind;
2656 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2657 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2658 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2659 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2660 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2661 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2662
2663 /* TO and FROM are guaranteed to have the same kind parameter. */
2664 name = gfc_get_string (PREFIX ("mvbits_i%d"),
2665 c->ext.actual->expr->ts.kind);
2666 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2667 /* Mark as elemental subroutine as this does not happen automatically. */
2668 c->resolved_sym->attr.elemental = 1;
2669
2670 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2671 of creating temporaries. */
2672 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2673 }
2674
2675
2676 void
2677 gfc_resolve_random_number (gfc_code *c)
2678 {
2679 const char *name;
2680 int kind;
2681
2682 kind = c->ext.actual->expr->ts.kind;
2683 if (c->ext.actual->expr->rank == 0)
2684 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2685 else
2686 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2687
2688 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2689 }
2690
2691
2692 void
2693 gfc_resolve_random_seed (gfc_code *c)
2694 {
2695 const char *name;
2696
2697 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2698 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2699 }
2700
2701
2702 void
2703 gfc_resolve_rename_sub (gfc_code *c)
2704 {
2705 const char *name;
2706 int kind;
2707
2708 if (c->ext.actual->next->next->expr != NULL)
2709 kind = c->ext.actual->next->next->expr->ts.kind;
2710 else
2711 kind = gfc_default_integer_kind;
2712
2713 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2714 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2715 }
2716
2717
2718 void
2719 gfc_resolve_kill_sub (gfc_code *c)
2720 {
2721 const char *name;
2722 int kind;
2723
2724 if (c->ext.actual->next->next->expr != NULL)
2725 kind = c->ext.actual->next->next->expr->ts.kind;
2726 else
2727 kind = gfc_default_integer_kind;
2728
2729 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2730 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2731 }
2732
2733
2734 void
2735 gfc_resolve_link_sub (gfc_code *c)
2736 {
2737 const char *name;
2738 int kind;
2739
2740 if (c->ext.actual->next->next->expr != NULL)
2741 kind = c->ext.actual->next->next->expr->ts.kind;
2742 else
2743 kind = gfc_default_integer_kind;
2744
2745 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2746 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2747 }
2748
2749
2750 void
2751 gfc_resolve_symlnk_sub (gfc_code *c)
2752 {
2753 const char *name;
2754 int kind;
2755
2756 if (c->ext.actual->next->next->expr != NULL)
2757 kind = c->ext.actual->next->next->expr->ts.kind;
2758 else
2759 kind = gfc_default_integer_kind;
2760
2761 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2762 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2763 }
2764
2765
2766 /* G77 compatibility subroutines dtime() and etime(). */
2767
2768 void
2769 gfc_resolve_dtime_sub (gfc_code *c)
2770 {
2771 const char *name;
2772 name = gfc_get_string (PREFIX ("dtime_sub"));
2773 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2774 }
2775
2776 void
2777 gfc_resolve_etime_sub (gfc_code *c)
2778 {
2779 const char *name;
2780 name = gfc_get_string (PREFIX ("etime_sub"));
2781 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2782 }
2783
2784
2785 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2786
2787 void
2788 gfc_resolve_itime (gfc_code *c)
2789 {
2790 c->resolved_sym
2791 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2792 gfc_default_integer_kind));
2793 }
2794
2795 void
2796 gfc_resolve_idate (gfc_code *c)
2797 {
2798 c->resolved_sym
2799 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2800 gfc_default_integer_kind));
2801 }
2802
2803 void
2804 gfc_resolve_ltime (gfc_code *c)
2805 {
2806 c->resolved_sym
2807 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2808 gfc_default_integer_kind));
2809 }
2810
2811 void
2812 gfc_resolve_gmtime (gfc_code *c)
2813 {
2814 c->resolved_sym
2815 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2816 gfc_default_integer_kind));
2817 }
2818
2819
2820 /* G77 compatibility subroutine second(). */
2821
2822 void
2823 gfc_resolve_second_sub (gfc_code *c)
2824 {
2825 const char *name;
2826 name = gfc_get_string (PREFIX ("second_sub"));
2827 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2828 }
2829
2830
2831 void
2832 gfc_resolve_sleep_sub (gfc_code *c)
2833 {
2834 const char *name;
2835 int kind;
2836
2837 if (c->ext.actual->expr != NULL)
2838 kind = c->ext.actual->expr->ts.kind;
2839 else
2840 kind = gfc_default_integer_kind;
2841
2842 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2843 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2844 }
2845
2846
2847 /* G77 compatibility function srand(). */
2848
2849 void
2850 gfc_resolve_srand (gfc_code *c)
2851 {
2852 const char *name;
2853 name = gfc_get_string (PREFIX ("srand"));
2854 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2855 }
2856
2857
2858 /* Resolve the getarg intrinsic subroutine. */
2859
2860 void
2861 gfc_resolve_getarg (gfc_code *c)
2862 {
2863 const char *name;
2864
2865 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2866 {
2867 gfc_typespec ts;
2868 gfc_clear_ts (&ts);
2869
2870 ts.type = BT_INTEGER;
2871 ts.kind = gfc_default_integer_kind;
2872
2873 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2874 }
2875
2876 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2877 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2878 }
2879
2880
2881 /* Resolve the getcwd intrinsic subroutine. */
2882
2883 void
2884 gfc_resolve_getcwd_sub (gfc_code *c)
2885 {
2886 const char *name;
2887 int kind;
2888
2889 if (c->ext.actual->next->expr != NULL)
2890 kind = c->ext.actual->next->expr->ts.kind;
2891 else
2892 kind = gfc_default_integer_kind;
2893
2894 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2895 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2896 }
2897
2898
2899 /* Resolve the get_command intrinsic subroutine. */
2900
2901 void
2902 gfc_resolve_get_command (gfc_code *c)
2903 {
2904 const char *name;
2905 int kind;
2906 kind = gfc_default_integer_kind;
2907 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2908 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2909 }
2910
2911
2912 /* Resolve the get_command_argument intrinsic subroutine. */
2913
2914 void
2915 gfc_resolve_get_command_argument (gfc_code *c)
2916 {
2917 const char *name;
2918 int kind;
2919 kind = gfc_default_integer_kind;
2920 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2921 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2922 }
2923
2924
2925 /* Resolve the get_environment_variable intrinsic subroutine. */
2926
2927 void
2928 gfc_resolve_get_environment_variable (gfc_code *code)
2929 {
2930 const char *name;
2931 int kind;
2932 kind = gfc_default_integer_kind;
2933 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2934 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2935 }
2936
2937
2938 void
2939 gfc_resolve_signal_sub (gfc_code *c)
2940 {
2941 const char *name;
2942 gfc_expr *number, *handler, *status;
2943 gfc_typespec ts;
2944 gfc_clear_ts (&ts);
2945
2946 number = c->ext.actual->expr;
2947 handler = c->ext.actual->next->expr;
2948 status = c->ext.actual->next->next->expr;
2949 ts.type = BT_INTEGER;
2950 ts.kind = gfc_c_int_kind;
2951
2952 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2953 if (handler->ts.type == BT_INTEGER)
2954 {
2955 if (handler->ts.kind != gfc_c_int_kind)
2956 gfc_convert_type (handler, &ts, 2);
2957 name = gfc_get_string (PREFIX ("signal_sub_int"));
2958 }
2959 else
2960 name = gfc_get_string (PREFIX ("signal_sub"));
2961
2962 if (number->ts.kind != gfc_c_int_kind)
2963 gfc_convert_type (number, &ts, 2);
2964 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2965 gfc_convert_type (status, &ts, 2);
2966
2967 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2968 }
2969
2970
2971 /* Resolve the SYSTEM intrinsic subroutine. */
2972
2973 void
2974 gfc_resolve_system_sub (gfc_code *c)
2975 {
2976 const char *name;
2977 name = gfc_get_string (PREFIX ("system_sub"));
2978 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2979 }
2980
2981
2982 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2983
2984 void
2985 gfc_resolve_system_clock (gfc_code *c)
2986 {
2987 const char *name;
2988 int kind;
2989
2990 if (c->ext.actual->expr != NULL)
2991 kind = c->ext.actual->expr->ts.kind;
2992 else if (c->ext.actual->next->expr != NULL)
2993 kind = c->ext.actual->next->expr->ts.kind;
2994 else if (c->ext.actual->next->next->expr != NULL)
2995 kind = c->ext.actual->next->next->expr->ts.kind;
2996 else
2997 kind = gfc_default_integer_kind;
2998
2999 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3000 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3001 }
3002
3003
3004 /* Resolve the EXIT intrinsic subroutine. */
3005
3006 void
3007 gfc_resolve_exit (gfc_code *c)
3008 {
3009 const char *name;
3010 gfc_typespec ts;
3011 gfc_expr *n;
3012 gfc_clear_ts (&ts);
3013
3014 /* The STATUS argument has to be of default kind. If it is not,
3015 we convert it. */
3016 ts.type = BT_INTEGER;
3017 ts.kind = gfc_default_integer_kind;
3018 n = c->ext.actual->expr;
3019 if (n != NULL && n->ts.kind != ts.kind)
3020 gfc_convert_type (n, &ts, 2);
3021
3022 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3023 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3024 }
3025
3026
3027 /* Resolve the FLUSH intrinsic subroutine. */
3028
3029 void
3030 gfc_resolve_flush (gfc_code *c)
3031 {
3032 const char *name;
3033 gfc_typespec ts;
3034 gfc_expr *n;
3035 gfc_clear_ts (&ts);
3036
3037 ts.type = BT_INTEGER;
3038 ts.kind = gfc_default_integer_kind;
3039 n = c->ext.actual->expr;
3040 if (n != NULL && n->ts.kind != ts.kind)
3041 gfc_convert_type (n, &ts, 2);
3042
3043 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3044 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3045 }
3046
3047
3048 void
3049 gfc_resolve_free (gfc_code *c)
3050 {
3051 gfc_typespec ts;
3052 gfc_expr *n;
3053 gfc_clear_ts (&ts);
3054
3055 ts.type = BT_INTEGER;
3056 ts.kind = gfc_index_integer_kind;
3057 n = c->ext.actual->expr;
3058 if (n->ts.kind != ts.kind)
3059 gfc_convert_type (n, &ts, 2);
3060
3061 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3062 }
3063
3064
3065 void
3066 gfc_resolve_ctime_sub (gfc_code *c)
3067 {
3068 gfc_typespec ts;
3069 gfc_clear_ts (&ts);
3070
3071 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3072 if (c->ext.actual->expr->ts.kind != 8)
3073 {
3074 ts.type = BT_INTEGER;
3075 ts.kind = 8;
3076 ts.derived = NULL;
3077 ts.cl = NULL;
3078 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3079 }
3080
3081 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3082 }
3083
3084
3085 void
3086 gfc_resolve_fdate_sub (gfc_code *c)
3087 {
3088 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3089 }
3090
3091
3092 void
3093 gfc_resolve_gerror (gfc_code *c)
3094 {
3095 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3096 }
3097
3098
3099 void
3100 gfc_resolve_getlog (gfc_code *c)
3101 {
3102 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3103 }
3104
3105
3106 void
3107 gfc_resolve_hostnm_sub (gfc_code *c)
3108 {
3109 const char *name;
3110 int kind;
3111
3112 if (c->ext.actual->next->expr != NULL)
3113 kind = c->ext.actual->next->expr->ts.kind;
3114 else
3115 kind = gfc_default_integer_kind;
3116
3117 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3118 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3119 }
3120
3121
3122 void
3123 gfc_resolve_perror (gfc_code *c)
3124 {
3125 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3126 }
3127
3128 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3129
3130 void
3131 gfc_resolve_stat_sub (gfc_code *c)
3132 {
3133 const char *name;
3134 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3135 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3136 }
3137
3138
3139 void
3140 gfc_resolve_lstat_sub (gfc_code *c)
3141 {
3142 const char *name;
3143 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3144 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3145 }
3146
3147
3148 void
3149 gfc_resolve_fstat_sub (gfc_code *c)
3150 {
3151 const char *name;
3152 gfc_expr *u;
3153 gfc_typespec *ts;
3154
3155 u = c->ext.actual->expr;
3156 ts = &c->ext.actual->next->expr->ts;
3157 if (u->ts.kind != ts->kind)
3158 gfc_convert_type (u, ts, 2);
3159 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3160 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3161 }
3162
3163
3164 void
3165 gfc_resolve_fgetc_sub (gfc_code *c)
3166 {
3167 const char *name;
3168 gfc_typespec ts;
3169 gfc_expr *u, *st;
3170 gfc_clear_ts (&ts);
3171
3172 u = c->ext.actual->expr;
3173 st = c->ext.actual->next->next->expr;
3174
3175 if (u->ts.kind != gfc_c_int_kind)
3176 {
3177 ts.type = BT_INTEGER;
3178 ts.kind = gfc_c_int_kind;
3179 ts.derived = NULL;
3180 ts.cl = NULL;
3181 gfc_convert_type (u, &ts, 2);
3182 }
3183
3184 if (st != NULL)
3185 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3186 else
3187 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3188
3189 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3190 }
3191
3192
3193 void
3194 gfc_resolve_fget_sub (gfc_code *c)
3195 {
3196 const char *name;
3197 gfc_expr *st;
3198
3199 st = c->ext.actual->next->expr;
3200 if (st != NULL)
3201 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3202 else
3203 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3204
3205 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3206 }
3207
3208
3209 void
3210 gfc_resolve_fputc_sub (gfc_code *c)
3211 {
3212 const char *name;
3213 gfc_typespec ts;
3214 gfc_expr *u, *st;
3215 gfc_clear_ts (&ts);
3216
3217 u = c->ext.actual->expr;
3218 st = c->ext.actual->next->next->expr;
3219
3220 if (u->ts.kind != gfc_c_int_kind)
3221 {
3222 ts.type = BT_INTEGER;
3223 ts.kind = gfc_c_int_kind;
3224 ts.derived = NULL;
3225 ts.cl = NULL;
3226 gfc_convert_type (u, &ts, 2);
3227 }
3228
3229 if (st != NULL)
3230 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3231 else
3232 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3233
3234 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3235 }
3236
3237
3238 void
3239 gfc_resolve_fput_sub (gfc_code *c)
3240 {
3241 const char *name;
3242 gfc_expr *st;
3243
3244 st = c->ext.actual->next->expr;
3245 if (st != NULL)
3246 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3247 else
3248 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3249
3250 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3251 }
3252
3253
3254 void
3255 gfc_resolve_fseek_sub (gfc_code *c)
3256 {
3257 gfc_expr *unit;
3258 gfc_expr *offset;
3259 gfc_expr *whence;
3260 gfc_expr *status;
3261 gfc_typespec ts;
3262 gfc_clear_ts (&ts);
3263
3264 unit = c->ext.actual->expr;
3265 offset = c->ext.actual->next->expr;
3266 whence = c->ext.actual->next->next->expr;
3267 status = c->ext.actual->next->next->next->expr;
3268
3269 if (unit->ts.kind != gfc_c_int_kind)
3270 {
3271 ts.type = BT_INTEGER;
3272 ts.kind = gfc_c_int_kind;
3273 ts.derived = NULL;
3274 ts.cl = NULL;
3275 gfc_convert_type (unit, &ts, 2);
3276 }
3277
3278 if (offset->ts.kind != gfc_intio_kind)
3279 {
3280 ts.type = BT_INTEGER;
3281 ts.kind = gfc_intio_kind;
3282 ts.derived = NULL;
3283 ts.cl = NULL;
3284 gfc_convert_type (offset, &ts, 2);
3285 }
3286
3287 if (whence->ts.kind != gfc_c_int_kind)
3288 {
3289 ts.type = BT_INTEGER;
3290 ts.kind = gfc_c_int_kind;
3291 ts.derived = NULL;
3292 ts.cl = NULL;
3293 gfc_convert_type (whence, &ts, 2);
3294 }
3295
3296 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3297 }
3298
3299 void
3300 gfc_resolve_ftell_sub (gfc_code *c)
3301 {
3302 const char *name;
3303 gfc_expr *unit;
3304 gfc_expr *offset;
3305 gfc_typespec ts;
3306 gfc_clear_ts (&ts);
3307
3308 unit = c->ext.actual->expr;
3309 offset = c->ext.actual->next->expr;
3310
3311 if (unit->ts.kind != gfc_c_int_kind)
3312 {
3313 ts.type = BT_INTEGER;
3314 ts.kind = gfc_c_int_kind;
3315 ts.derived = NULL;
3316 ts.cl = NULL;
3317 gfc_convert_type (unit, &ts, 2);
3318 }
3319
3320 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3321 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3322 }
3323
3324
3325 void
3326 gfc_resolve_ttynam_sub (gfc_code *c)
3327 {
3328 gfc_typespec ts;
3329 gfc_clear_ts (&ts);
3330
3331 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3332 {
3333 ts.type = BT_INTEGER;
3334 ts.kind = gfc_c_int_kind;
3335 ts.derived = NULL;
3336 ts.cl = NULL;
3337 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3338 }
3339
3340 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3341 }
3342
3343
3344 /* Resolve the UMASK intrinsic subroutine. */
3345
3346 void
3347 gfc_resolve_umask_sub (gfc_code *c)
3348 {
3349 const char *name;
3350 int kind;
3351
3352 if (c->ext.actual->next->expr != NULL)
3353 kind = c->ext.actual->next->expr->ts.kind;
3354 else
3355 kind = gfc_default_integer_kind;
3356
3357 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3358 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3359 }
3360
3361 /* Resolve the UNLINK intrinsic subroutine. */
3362
3363 void
3364 gfc_resolve_unlink_sub (gfc_code *c)
3365 {
3366 const char *name;
3367 int kind;
3368
3369 if (c->ext.actual->next->expr != NULL)
3370 kind = c->ext.actual->next->expr->ts.kind;
3371 else
3372 kind = gfc_default_integer_kind;
3373
3374 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3375 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3376 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org