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