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