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