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