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