]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Intrinsic function resolution. |
9fc4d79b TS |
2 | Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, |
3 | Inc. | |
6de9cd9a DN |
4 | Contributed by Andy Vaught & Katherine Holcomb |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
10 | Software Foundation; either version 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b TS |
19 | along with GCC; see the file COPYING. If not, write to the Free |
20 | Software Foundation, 59 Temple Place - Suite 330, Boston, MA | |
21 | 02111-1307, USA. */ | |
6de9cd9a DN |
22 | |
23 | ||
24 | /* Assign name and types to intrinsic procedures. For functions, the | |
25 | first argument to a resolution function is an expression pointer to | |
26 | the original function node and the rest are pointers to the | |
27 | arguments of the function call. For subroutines, a pointer to the | |
28 | code node is passed. The result type and library subroutine name | |
29 | are generally set according to the function arguments. */ | |
30 | ||
31 | #include "config.h" | |
32 | #include <string.h> | |
33 | #include <stdarg.h> | |
34 | ||
35 | #include "gfortran.h" | |
36 | #include "intrinsic.h" | |
37 | ||
38 | ||
39 | /* String pool subroutines. This are used to provide static locations | |
40 | for the string constants that represent library function names. */ | |
41 | ||
42 | typedef struct string_node | |
43 | { | |
44 | struct string_node *next; | |
45 | char string[1]; | |
46 | } | |
47 | string_node; | |
48 | ||
49 | #define HASH_SIZE 13 | |
50 | ||
51 | static string_node *string_head[HASH_SIZE]; | |
52 | ||
53 | ||
54 | /* Return a hash code based on the name. */ | |
55 | ||
56 | static int | |
57 | hash (const char *name) | |
58 | { | |
59 | int h; | |
60 | ||
61 | h = 1; | |
62 | while (*name) | |
63 | h = 5311966 * h + *name++; | |
64 | ||
65 | if (h < 0) | |
66 | h = -h; | |
67 | return h % HASH_SIZE; | |
68 | } | |
69 | ||
70 | ||
71 | /* Given printf-like arguments, return a static address of the | |
72 | resulting string. If the name is not in the table, it is added. */ | |
73 | ||
74 | char * | |
75 | gfc_get_string (const char *format, ...) | |
76 | { | |
77 | char temp_name[50]; | |
78 | string_node *p; | |
79 | va_list ap; | |
80 | int h; | |
81 | ||
82 | va_start (ap, format); | |
83 | vsprintf (temp_name, format, ap); | |
84 | va_end (ap); | |
85 | ||
86 | h = hash (temp_name); | |
87 | ||
88 | /* Search */ | |
89 | for (p = string_head[h]; p; p = p->next) | |
90 | if (strcmp (p->string, temp_name) == 0) | |
91 | return p->string; | |
92 | ||
93 | /* Add */ | |
94 | p = gfc_getmem (sizeof (string_node) + strlen (temp_name)); | |
95 | ||
96 | strcpy (p->string, temp_name); | |
97 | ||
98 | p->next = string_head[h]; | |
99 | string_head[h] = p; | |
100 | ||
101 | return p->string; | |
102 | } | |
103 | ||
104 | ||
105 | ||
106 | static void | |
107 | free_strings (void) | |
108 | { | |
109 | string_node *p, *q; | |
110 | int h; | |
111 | ||
112 | for (h = 0; h < HASH_SIZE; h++) | |
113 | { | |
114 | for (p = string_head[h]; p; p = q) | |
115 | { | |
116 | q = p->next; | |
117 | gfc_free (p); | |
118 | } | |
119 | } | |
120 | } | |
121 | ||
122 | ||
123 | /********************** Resolution functions **********************/ | |
124 | ||
125 | ||
126 | void | |
127 | gfc_resolve_abs (gfc_expr * f, gfc_expr * a) | |
128 | { | |
129 | ||
130 | f->ts = a->ts; | |
131 | if (f->ts.type == BT_COMPLEX) | |
132 | f->ts.type = BT_REAL; | |
133 | ||
134 | f->value.function.name = | |
135 | gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
136 | } | |
137 | ||
138 | ||
139 | void | |
140 | gfc_resolve_acos (gfc_expr * f, gfc_expr * x) | |
141 | { | |
142 | ||
143 | f->ts = x->ts; | |
144 | f->value.function.name = | |
145 | gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
146 | } | |
147 | ||
148 | ||
149 | void | |
150 | gfc_resolve_aimag (gfc_expr * f, gfc_expr * x) | |
151 | { | |
152 | ||
153 | f->ts.type = BT_REAL; | |
154 | f->ts.kind = x->ts.kind; | |
155 | f->value.function.name = | |
156 | gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
157 | } | |
158 | ||
159 | ||
160 | void | |
161 | gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
162 | { | |
163 | ||
164 | f->ts.type = a->ts.type; | |
165 | f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); | |
166 | ||
167 | /* The resolved name is only used for specific intrinsics where | |
168 | the return kind is the same as the arg kind. */ | |
169 | f->value.function.name = | |
170 | gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
171 | } | |
172 | ||
173 | ||
174 | void | |
175 | gfc_resolve_dint (gfc_expr * f, gfc_expr * a) | |
176 | { | |
177 | gfc_resolve_aint (f, a, NULL); | |
178 | } | |
179 | ||
180 | ||
181 | void | |
182 | gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) | |
183 | { | |
184 | ||
185 | f->ts = mask->ts; | |
186 | ||
187 | if (dim != NULL) | |
188 | { | |
189 | gfc_resolve_index (dim, 1); | |
190 | f->rank = mask->rank - 1; | |
191 | } | |
192 | ||
193 | f->value.function.name = | |
194 | gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type), | |
195 | mask->ts.kind); | |
196 | } | |
197 | ||
198 | ||
199 | void | |
200 | gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
201 | { | |
202 | ||
203 | f->ts.type = a->ts.type; | |
204 | f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); | |
205 | ||
206 | /* The resolved name is only used for specific intrinsics where | |
207 | the return kind is the same as the arg kind. */ | |
208 | f->value.function.name = | |
209 | gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
210 | } | |
211 | ||
212 | ||
213 | void | |
214 | gfc_resolve_dnint (gfc_expr * f, gfc_expr * a) | |
215 | { | |
216 | gfc_resolve_anint (f, a, NULL); | |
217 | } | |
218 | ||
219 | ||
220 | void | |
221 | gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) | |
222 | { | |
223 | ||
224 | f->ts = mask->ts; | |
225 | ||
226 | if (dim != NULL) | |
227 | { | |
228 | gfc_resolve_index (dim, 1); | |
229 | f->rank = mask->rank - 1; | |
230 | } | |
231 | ||
232 | f->value.function.name = | |
233 | gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type), | |
234 | mask->ts.kind); | |
235 | } | |
236 | ||
237 | ||
238 | void | |
239 | gfc_resolve_asin (gfc_expr * f, gfc_expr * x) | |
240 | { | |
241 | ||
242 | f->ts = x->ts; | |
243 | f->value.function.name = | |
244 | gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
245 | } | |
246 | ||
247 | ||
248 | void | |
249 | gfc_resolve_atan (gfc_expr * f, gfc_expr * x) | |
250 | { | |
251 | ||
252 | f->ts = x->ts; | |
253 | f->value.function.name = | |
254 | gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
255 | } | |
256 | ||
257 | ||
258 | void | |
259 | gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x, | |
260 | gfc_expr * y ATTRIBUTE_UNUSED) | |
261 | { | |
262 | ||
263 | f->ts = x->ts; | |
264 | f->value.function.name = | |
265 | gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
266 | } | |
267 | ||
268 | ||
269 | void | |
270 | gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos) | |
271 | { | |
272 | ||
273 | f->ts.type = BT_LOGICAL; | |
274 | f->ts.kind = gfc_default_logical_kind (); | |
275 | ||
276 | f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind, | |
277 | pos->ts.kind); | |
278 | } | |
279 | ||
280 | ||
281 | void | |
282 | gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
283 | { | |
284 | ||
285 | f->ts.type = BT_INTEGER; | |
286 | f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () | |
287 | : mpz_get_si (kind->value.integer); | |
288 | ||
289 | f->value.function.name = | |
290 | gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind, | |
291 | gfc_type_letter (a->ts.type), a->ts.kind); | |
292 | } | |
293 | ||
294 | ||
295 | void | |
296 | gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
297 | { | |
298 | ||
299 | f->ts.type = BT_CHARACTER; | |
300 | f->ts.kind = (kind == NULL) ? gfc_default_character_kind () | |
301 | : mpz_get_si (kind->value.integer); | |
302 | ||
303 | f->value.function.name = | |
304 | gfc_get_string ("__char_%d_%c%d", f->ts.kind, | |
305 | gfc_type_letter (a->ts.type), a->ts.kind); | |
306 | } | |
307 | ||
308 | ||
309 | void | |
310 | gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind) | |
311 | { | |
312 | ||
313 | f->ts.type = BT_COMPLEX; | |
314 | f->ts.kind = (kind == NULL) ? gfc_default_real_kind () | |
315 | : mpz_get_si (kind->value.integer); | |
316 | ||
317 | if (y == NULL) | |
318 | f->value.function.name = | |
319 | gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind, | |
320 | gfc_type_letter (x->ts.type), x->ts.kind); | |
321 | else | |
322 | f->value.function.name = | |
323 | gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, | |
324 | gfc_type_letter (x->ts.type), x->ts.kind, | |
325 | gfc_type_letter (y->ts.type), y->ts.kind); | |
326 | } | |
327 | ||
328 | void | |
329 | gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y) | |
330 | { | |
331 | gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind ())); | |
332 | } | |
333 | ||
334 | void | |
335 | gfc_resolve_conjg (gfc_expr * f, gfc_expr * x) | |
336 | { | |
337 | ||
338 | f->ts = x->ts; | |
339 | f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind); | |
340 | } | |
341 | ||
342 | ||
343 | void | |
344 | gfc_resolve_cos (gfc_expr * f, gfc_expr * x) | |
345 | { | |
346 | ||
347 | f->ts = x->ts; | |
348 | f->value.function.name = | |
349 | gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
350 | } | |
351 | ||
352 | ||
353 | void | |
354 | gfc_resolve_cosh (gfc_expr * f, gfc_expr * x) | |
355 | { | |
356 | ||
357 | f->ts = x->ts; | |
358 | f->value.function.name = | |
359 | gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
360 | } | |
361 | ||
362 | ||
363 | void | |
364 | gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) | |
365 | { | |
366 | ||
367 | f->ts.type = BT_INTEGER; | |
368 | f->ts.kind = gfc_default_integer_kind (); | |
369 | ||
370 | if (dim != NULL) | |
371 | { | |
372 | f->rank = mask->rank - 1; | |
373 | gfc_resolve_index (dim, 1); | |
374 | } | |
375 | ||
376 | f->value.function.name = | |
377 | gfc_get_string ("__count_%d_%c%d", f->ts.kind, | |
378 | gfc_type_letter (mask->ts.type), mask->ts.kind); | |
379 | } | |
380 | ||
381 | ||
382 | void | |
383 | gfc_resolve_cshift (gfc_expr * f, gfc_expr * array, | |
384 | gfc_expr * shift, | |
385 | gfc_expr * dim) | |
386 | { | |
387 | int n; | |
388 | ||
389 | f->ts = array->ts; | |
390 | f->rank = array->rank; | |
391 | ||
392 | if (shift->rank > 0) | |
393 | n = 1; | |
394 | else | |
395 | n = 0; | |
396 | ||
397 | if (dim != NULL) | |
398 | { | |
399 | gfc_resolve_index (dim, 1); | |
400 | /* Convert dim to shift's kind, so we don't need so many variations. */ | |
401 | if (dim->ts.kind != shift->ts.kind) | |
402 | gfc_convert_type (dim, &shift->ts, 2); | |
403 | } | |
404 | f->value.function.name = | |
405 | gfc_get_string ("__cshift%d_%d", n, shift->ts.kind); | |
406 | } | |
407 | ||
408 | ||
409 | void | |
410 | gfc_resolve_dble (gfc_expr * f, gfc_expr * a) | |
411 | { | |
412 | ||
413 | f->ts.type = BT_REAL; | |
414 | f->ts.kind = gfc_default_double_kind (); | |
415 | f->value.function.name = | |
416 | gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
417 | } | |
418 | ||
419 | ||
420 | void | |
421 | gfc_resolve_dim (gfc_expr * f, gfc_expr * x, | |
422 | gfc_expr * y ATTRIBUTE_UNUSED) | |
423 | { | |
424 | ||
425 | f->ts = x->ts; | |
426 | f->value.function.name = | |
427 | gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
428 | } | |
429 | ||
430 | ||
431 | void | |
432 | gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b) | |
433 | { | |
434 | gfc_expr temp; | |
435 | ||
436 | if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) | |
437 | { | |
438 | f->ts.type = BT_LOGICAL; | |
439 | f->ts.kind = gfc_default_logical_kind (); | |
440 | } | |
441 | else | |
442 | { | |
443 | temp.expr_type = EXPR_OP; | |
444 | gfc_clear_ts (&temp.ts); | |
445 | temp.operator = INTRINSIC_NONE; | |
446 | temp.op1 = a; | |
447 | temp.op2 = b; | |
448 | gfc_type_convert_binary (&temp); | |
449 | f->ts = temp.ts; | |
450 | } | |
451 | ||
452 | f->value.function.name = | |
453 | gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type), | |
454 | f->ts.kind); | |
455 | } | |
456 | ||
457 | ||
458 | void | |
459 | gfc_resolve_dprod (gfc_expr * f, | |
460 | gfc_expr * a ATTRIBUTE_UNUSED, | |
461 | gfc_expr * b ATTRIBUTE_UNUSED) | |
462 | { | |
463 | f->ts.kind = gfc_default_double_kind (); | |
464 | f->ts.type = BT_REAL; | |
465 | ||
466 | f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind); | |
467 | } | |
468 | ||
469 | ||
470 | void | |
471 | gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array, | |
472 | gfc_expr * shift, | |
473 | gfc_expr * boundary, | |
474 | gfc_expr * dim) | |
475 | { | |
476 | int n; | |
477 | ||
478 | f->ts = array->ts; | |
479 | f->rank = array->rank; | |
480 | ||
481 | n = 0; | |
482 | if (shift->rank > 0) | |
483 | n = n | 1; | |
484 | if (boundary && boundary->rank > 0) | |
485 | n = n | 2; | |
486 | ||
487 | /* Convert dim to the same type as shift, so we don't need quite so many | |
488 | variations. */ | |
489 | if (dim != NULL && dim->ts.kind != shift->ts.kind) | |
490 | gfc_convert_type (dim, &shift->ts, 2); | |
491 | ||
492 | f->value.function.name = | |
493 | gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind); | |
494 | } | |
495 | ||
496 | ||
497 | void | |
498 | gfc_resolve_exp (gfc_expr * f, gfc_expr * x) | |
499 | { | |
500 | ||
501 | f->ts = x->ts; | |
502 | f->value.function.name = | |
503 | gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
504 | } | |
505 | ||
506 | ||
507 | void | |
508 | gfc_resolve_exponent (gfc_expr * f, gfc_expr * x) | |
509 | { | |
510 | ||
511 | f->ts.type = BT_INTEGER; | |
512 | f->ts.kind = gfc_default_integer_kind (); | |
513 | ||
514 | f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind); | |
515 | } | |
516 | ||
517 | ||
518 | void | |
519 | gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
520 | { | |
521 | ||
522 | f->ts.type = BT_INTEGER; | |
523 | f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () | |
524 | : mpz_get_si (kind->value.integer); | |
525 | ||
526 | f->value.function.name = | |
527 | gfc_get_string ("__floor%d_%c%d", f->ts.kind, | |
528 | gfc_type_letter (a->ts.type), a->ts.kind); | |
529 | } | |
530 | ||
531 | ||
532 | void | |
533 | gfc_resolve_fraction (gfc_expr * f, gfc_expr * x) | |
534 | { | |
535 | ||
536 | f->ts = x->ts; | |
537 | f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind); | |
538 | } | |
539 | ||
540 | ||
541 | void | |
542 | gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED) | |
543 | { | |
544 | ||
545 | f->ts = i->ts; | |
546 | f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); | |
547 | } | |
548 | ||
549 | ||
550 | void | |
551 | gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED) | |
552 | { | |
553 | ||
554 | f->ts = i->ts; | |
555 | f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); | |
556 | } | |
557 | ||
558 | ||
559 | void | |
560 | gfc_resolve_ibits (gfc_expr * f, gfc_expr * i, | |
561 | gfc_expr * pos ATTRIBUTE_UNUSED, | |
562 | gfc_expr * len ATTRIBUTE_UNUSED) | |
563 | { | |
564 | ||
565 | f->ts = i->ts; | |
566 | f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); | |
567 | } | |
568 | ||
569 | ||
570 | void | |
571 | gfc_resolve_ibset (gfc_expr * f, gfc_expr * i, | |
572 | gfc_expr * pos ATTRIBUTE_UNUSED) | |
573 | { | |
574 | ||
575 | f->ts = i->ts; | |
576 | f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); | |
577 | } | |
578 | ||
579 | ||
580 | void | |
581 | gfc_resolve_ichar (gfc_expr * f, gfc_expr * c) | |
582 | { | |
583 | ||
584 | f->ts.type = BT_INTEGER; | |
585 | f->ts.kind = gfc_default_integer_kind (); | |
586 | ||
587 | f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); | |
588 | } | |
589 | ||
590 | ||
591 | void | |
592 | gfc_resolve_idnint (gfc_expr * f, gfc_expr * a) | |
593 | { | |
594 | gfc_resolve_nint (f, a, NULL); | |
595 | } | |
596 | ||
597 | ||
598 | void | |
599 | gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, | |
600 | gfc_expr * j ATTRIBUTE_UNUSED) | |
601 | { | |
602 | ||
603 | f->ts = i->ts; | |
604 | f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); | |
605 | } | |
606 | ||
607 | ||
608 | void | |
609 | gfc_resolve_ior (gfc_expr * f, gfc_expr * i, | |
610 | gfc_expr * j ATTRIBUTE_UNUSED) | |
611 | { | |
612 | ||
613 | f->ts = i->ts; | |
614 | f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); | |
615 | } | |
616 | ||
617 | ||
618 | void | |
619 | gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
620 | { | |
621 | ||
622 | f->ts.type = BT_INTEGER; | |
623 | f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () | |
624 | : mpz_get_si (kind->value.integer); | |
625 | ||
626 | f->value.function.name = | |
627 | gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type), | |
628 | a->ts.kind); | |
629 | } | |
630 | ||
631 | ||
632 | void | |
633 | gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift) | |
634 | { | |
635 | ||
636 | f->ts = i->ts; | |
637 | f->value.function.name = | |
638 | gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind); | |
639 | } | |
640 | ||
641 | ||
642 | void | |
643 | gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift, | |
644 | gfc_expr * size) | |
645 | { | |
646 | int s_kind; | |
647 | ||
648 | s_kind = (size == NULL) ? gfc_default_integer_kind () : shift->ts.kind; | |
649 | ||
650 | f->ts = i->ts; | |
651 | f->value.function.name = | |
652 | gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind); | |
653 | } | |
654 | ||
655 | ||
656 | void | |
657 | gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, | |
658 | gfc_expr * dim) | |
659 | { | |
660 | static char lbound[] = "__lbound"; | |
661 | ||
662 | f->ts.type = BT_INTEGER; | |
663 | f->ts.kind = gfc_default_integer_kind (); | |
664 | ||
665 | f->rank = (dim == NULL) ? 1 : 0; | |
666 | f->value.function.name = lbound; | |
667 | } | |
668 | ||
669 | ||
670 | void | |
671 | gfc_resolve_len (gfc_expr * f, gfc_expr * string) | |
672 | { | |
673 | ||
674 | f->ts.type = BT_INTEGER; | |
675 | f->ts.kind = gfc_default_integer_kind (); | |
676 | f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind); | |
677 | } | |
678 | ||
679 | ||
680 | void | |
681 | gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string) | |
682 | { | |
683 | ||
684 | f->ts.type = BT_INTEGER; | |
685 | f->ts.kind = gfc_default_integer_kind (); | |
686 | f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind); | |
687 | } | |
688 | ||
689 | ||
690 | void | |
691 | gfc_resolve_log (gfc_expr * f, gfc_expr * x) | |
692 | { | |
693 | ||
694 | f->ts = x->ts; | |
695 | f->value.function.name = | |
696 | gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
697 | } | |
698 | ||
699 | ||
700 | void | |
701 | gfc_resolve_log10 (gfc_expr * f, gfc_expr * x) | |
702 | { | |
703 | ||
704 | f->ts = x->ts; | |
705 | f->value.function.name = | |
706 | gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
707 | } | |
708 | ||
709 | ||
710 | void | |
711 | gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
712 | { | |
713 | ||
714 | f->ts.type = BT_LOGICAL; | |
715 | f->ts.kind = (kind == NULL) ? gfc_default_logical_kind () | |
716 | : mpz_get_si (kind->value.integer); | |
717 | f->rank = a->rank; | |
718 | ||
719 | f->value.function.name = | |
720 | gfc_get_string ("__logical_%d_%c%d", f->ts.kind, | |
721 | gfc_type_letter (a->ts.type), a->ts.kind); | |
722 | } | |
723 | ||
724 | ||
725 | void | |
726 | gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b) | |
727 | { | |
728 | gfc_expr temp; | |
729 | ||
730 | if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) | |
731 | { | |
732 | f->ts.type = BT_LOGICAL; | |
733 | f->ts.kind = gfc_default_logical_kind (); | |
734 | } | |
735 | else | |
736 | { | |
737 | temp.expr_type = EXPR_OP; | |
738 | gfc_clear_ts (&temp.ts); | |
739 | temp.operator = INTRINSIC_NONE; | |
740 | temp.op1 = a; | |
741 | temp.op2 = b; | |
742 | gfc_type_convert_binary (&temp); | |
743 | f->ts = temp.ts; | |
744 | } | |
745 | ||
746 | f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1; | |
747 | ||
748 | f->value.function.name = | |
749 | gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type), | |
750 | f->ts.kind); | |
751 | } | |
752 | ||
753 | ||
754 | static void | |
755 | gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args) | |
756 | { | |
757 | gfc_actual_arglist *a; | |
758 | ||
759 | f->ts.type = args->expr->ts.type; | |
760 | f->ts.kind = args->expr->ts.kind; | |
761 | /* Find the largest type kind. */ | |
762 | for (a = args->next; a; a = a->next) | |
763 | { | |
764 | if (a->expr->ts.kind > f->ts.kind) | |
765 | f->ts.kind = a->expr->ts.kind; | |
766 | } | |
767 | ||
768 | /* Convert all parameters to the required kind. */ | |
769 | for (a = args; a; a = a->next) | |
770 | { | |
771 | if (a->expr->ts.kind != f->ts.kind) | |
772 | gfc_convert_type (a->expr, &f->ts, 2); | |
773 | } | |
774 | ||
775 | f->value.function.name = | |
776 | gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind); | |
777 | } | |
778 | ||
779 | ||
780 | void | |
781 | gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args) | |
782 | { | |
783 | gfc_resolve_minmax ("__max_%c%d", f, args); | |
784 | } | |
785 | ||
786 | ||
787 | void | |
788 | gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
789 | gfc_expr * mask) | |
790 | { | |
791 | const char *name; | |
792 | ||
793 | f->ts.type = BT_INTEGER; | |
794 | f->ts.kind = gfc_default_integer_kind (); | |
795 | ||
796 | if (dim == NULL) | |
797 | f->rank = 1; | |
798 | else | |
799 | { | |
800 | f->rank = array->rank - 1; | |
801 | gfc_resolve_index (dim, 1); | |
802 | } | |
803 | ||
804 | name = mask ? "mmaxloc" : "maxloc"; | |
805 | f->value.function.name = | |
806 | gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind, | |
807 | gfc_type_letter (array->ts.type), array->ts.kind); | |
808 | } | |
809 | ||
810 | ||
811 | void | |
812 | gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
813 | gfc_expr * mask) | |
814 | { | |
815 | ||
816 | f->ts = array->ts; | |
817 | ||
818 | if (dim != NULL) | |
819 | { | |
820 | f->rank = array->rank - 1; | |
821 | gfc_resolve_index (dim, 1); | |
822 | } | |
823 | ||
824 | f->value.function.name = | |
825 | gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval", | |
826 | gfc_type_letter (array->ts.type), array->ts.kind); | |
827 | } | |
828 | ||
829 | ||
830 | void | |
831 | gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource, | |
832 | gfc_expr * fsource ATTRIBUTE_UNUSED, | |
833 | gfc_expr * mask ATTRIBUTE_UNUSED) | |
834 | { | |
835 | ||
836 | f->ts = tsource->ts; | |
837 | f->value.function.name = | |
838 | gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), | |
839 | tsource->ts.kind); | |
840 | } | |
841 | ||
842 | ||
843 | void | |
844 | gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args) | |
845 | { | |
846 | gfc_resolve_minmax ("__min_%c%d", f, args); | |
847 | } | |
848 | ||
849 | ||
850 | void | |
851 | gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
852 | gfc_expr * mask) | |
853 | { | |
854 | const char *name; | |
855 | ||
856 | f->ts.type = BT_INTEGER; | |
857 | f->ts.kind = gfc_default_integer_kind (); | |
858 | ||
859 | if (dim == NULL) | |
860 | f->rank = 1; | |
861 | else | |
862 | { | |
863 | f->rank = array->rank - 1; | |
864 | gfc_resolve_index (dim, 1); | |
865 | } | |
866 | ||
867 | name = mask ? "mminloc" : "minloc"; | |
868 | f->value.function.name = | |
869 | gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind, | |
870 | gfc_type_letter (array->ts.type), array->ts.kind); | |
871 | } | |
872 | ||
873 | void | |
874 | gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
875 | gfc_expr * mask) | |
876 | { | |
877 | ||
878 | f->ts = array->ts; | |
879 | ||
880 | if (dim != NULL) | |
881 | { | |
882 | f->rank = array->rank - 1; | |
883 | gfc_resolve_index (dim, 1); | |
884 | } | |
885 | ||
886 | f->value.function.name = | |
887 | gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval", | |
888 | gfc_type_letter (array->ts.type), array->ts.kind); | |
889 | } | |
890 | ||
891 | ||
892 | void | |
893 | gfc_resolve_mod (gfc_expr * f, gfc_expr * a, | |
894 | gfc_expr * p ATTRIBUTE_UNUSED) | |
895 | { | |
896 | ||
897 | f->ts = a->ts; | |
898 | f->value.function.name = | |
899 | gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
900 | } | |
901 | ||
902 | ||
903 | void | |
904 | gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, | |
905 | gfc_expr * p ATTRIBUTE_UNUSED) | |
906 | { | |
907 | ||
908 | f->ts = a->ts; | |
909 | f->value.function.name = | |
910 | gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type), | |
911 | a->ts.kind); | |
912 | } | |
913 | ||
8765339d TS |
914 | void |
915 | gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, | |
916 | gfc_expr *p ATTRIBUTE_UNUSED) | |
917 | { | |
918 | ||
919 | f->ts = a->ts; | |
920 | f->value.function.name = | |
921 | gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type), | |
922 | a->ts.kind); | |
923 | } | |
6de9cd9a DN |
924 | |
925 | void | |
926 | gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
927 | { | |
928 | ||
929 | f->ts.type = BT_INTEGER; | |
930 | f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () | |
931 | : mpz_get_si (kind->value.integer); | |
932 | ||
933 | f->value.function.name = | |
934 | gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind); | |
935 | } | |
936 | ||
937 | ||
938 | void | |
939 | gfc_resolve_not (gfc_expr * f, gfc_expr * i) | |
940 | { | |
941 | ||
942 | f->ts = i->ts; | |
943 | f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); | |
944 | } | |
945 | ||
946 | ||
947 | void | |
948 | gfc_resolve_pack (gfc_expr * f, | |
949 | gfc_expr * array ATTRIBUTE_UNUSED, | |
950 | gfc_expr * mask ATTRIBUTE_UNUSED, | |
951 | gfc_expr * vector ATTRIBUTE_UNUSED) | |
952 | { | |
953 | static char pack[] = "__pack"; | |
954 | ||
955 | f->ts = array->ts; | |
956 | f->rank = 1; | |
957 | ||
958 | f->value.function.name = pack; | |
959 | } | |
960 | ||
961 | ||
962 | void | |
963 | gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
964 | gfc_expr * mask) | |
965 | { | |
966 | ||
967 | f->ts = array->ts; | |
968 | ||
969 | if (dim != NULL) | |
970 | { | |
971 | f->rank = array->rank - 1; | |
972 | gfc_resolve_index (dim, 1); | |
973 | } | |
974 | ||
975 | f->value.function.name = | |
976 | gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product", | |
977 | gfc_type_letter (array->ts.type), array->ts.kind); | |
978 | } | |
979 | ||
980 | ||
981 | void | |
982 | gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind) | |
983 | { | |
984 | ||
985 | f->ts.type = BT_REAL; | |
986 | ||
987 | if (kind != NULL) | |
988 | f->ts.kind = mpz_get_si (kind->value.integer); | |
989 | else | |
990 | f->ts.kind = (a->ts.type == BT_COMPLEX) ? | |
991 | a->ts.kind : gfc_default_real_kind (); | |
992 | ||
993 | f->value.function.name = | |
994 | gfc_get_string ("__real_%d_%c%d", f->ts.kind, | |
995 | gfc_type_letter (a->ts.type), a->ts.kind); | |
996 | } | |
997 | ||
998 | ||
999 | void | |
1000 | gfc_resolve_repeat (gfc_expr * f, gfc_expr * string, | |
1001 | gfc_expr * ncopies ATTRIBUTE_UNUSED) | |
1002 | { | |
1003 | ||
1004 | f->ts.type = BT_CHARACTER; | |
1005 | f->ts.kind = string->ts.kind; | |
1006 | f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); | |
1007 | } | |
1008 | ||
1009 | ||
1010 | void | |
1011 | gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape, | |
1012 | gfc_expr * pad ATTRIBUTE_UNUSED, | |
1013 | gfc_expr * order ATTRIBUTE_UNUSED) | |
1014 | { | |
1015 | static char reshape0[] = "__reshape"; | |
1016 | mpz_t rank; | |
1017 | int kind; | |
1018 | int i; | |
1019 | ||
1020 | f->ts = source->ts; | |
1021 | ||
1022 | gfc_array_size (shape, &rank); | |
1023 | f->rank = mpz_get_si (rank); | |
1024 | mpz_clear (rank); | |
1025 | switch (source->ts.type) | |
1026 | { | |
1027 | case BT_COMPLEX: | |
1028 | kind = source->ts.kind * 2; | |
1029 | break; | |
1030 | ||
1031 | case BT_REAL: | |
1032 | case BT_INTEGER: | |
1033 | case BT_LOGICAL: | |
1034 | kind = source->ts.kind; | |
1035 | break; | |
1036 | ||
1037 | default: | |
1038 | kind = 0; | |
1039 | break; | |
1040 | } | |
1041 | ||
1042 | switch (kind) | |
1043 | { | |
1044 | case 4: | |
1045 | case 8: | |
1046 | /* case 16: */ | |
1047 | f->value.function.name = | |
1048 | gfc_get_string ("__reshape_%d", source->ts.kind); | |
1049 | break; | |
1050 | ||
1051 | default: | |
1052 | f->value.function.name = reshape0; | |
1053 | break; | |
1054 | } | |
1055 | ||
1056 | /* TODO: Make this work with a constant ORDER parameter. */ | |
1057 | if (shape->expr_type == EXPR_ARRAY | |
1058 | && gfc_is_constant_expr (shape) | |
1059 | && order == NULL) | |
1060 | { | |
1061 | gfc_constructor *c; | |
1062 | f->shape = gfc_get_shape (f->rank); | |
1063 | c = shape->value.constructor; | |
1064 | for (i = 0; i < f->rank; i++) | |
1065 | { | |
1066 | mpz_init_set (f->shape[i], c->expr->value.integer); | |
1067 | c = c->next; | |
1068 | } | |
1069 | } | |
1070 | } | |
1071 | ||
1072 | ||
1073 | void | |
1074 | gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x) | |
1075 | { | |
1076 | ||
1077 | f->ts = x->ts; | |
1078 | f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); | |
1079 | } | |
1080 | ||
1081 | ||
1082 | void | |
1083 | gfc_resolve_scale (gfc_expr * f, gfc_expr * x, | |
1084 | gfc_expr * y ATTRIBUTE_UNUSED) | |
1085 | { | |
1086 | ||
1087 | f->ts = x->ts; | |
1088 | f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind, | |
1089 | x->ts.kind); | |
1090 | } | |
1091 | ||
1092 | ||
1093 | void | |
1094 | gfc_resolve_scan (gfc_expr * f, gfc_expr * string, | |
1095 | gfc_expr * set ATTRIBUTE_UNUSED, | |
1096 | gfc_expr * back ATTRIBUTE_UNUSED) | |
1097 | { | |
1098 | ||
1099 | f->ts.type = BT_INTEGER; | |
1100 | f->ts.kind = gfc_default_integer_kind (); | |
1101 | f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind); | |
1102 | } | |
1103 | ||
1104 | ||
1105 | void | |
1106 | gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i) | |
1107 | { | |
1108 | ||
1109 | f->ts = x->ts; | |
1110 | f->value.function.name = | |
1111 | gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind); | |
1112 | } | |
1113 | ||
1114 | ||
1115 | void | |
1116 | gfc_resolve_shape (gfc_expr * f, gfc_expr * array) | |
1117 | { | |
1118 | ||
1119 | f->ts.type = BT_INTEGER; | |
1120 | f->ts.kind = gfc_default_integer_kind (); | |
1121 | f->rank = 1; | |
1122 | f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind); | |
1123 | f->shape = gfc_get_shape (1); | |
1124 | mpz_init_set_ui (f->shape[0], array->rank); | |
1125 | } | |
1126 | ||
1127 | ||
1128 | void | |
1129 | gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED) | |
1130 | { | |
1131 | ||
1132 | f->ts = a->ts; | |
1133 | f->value.function.name = | |
1134 | gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); | |
1135 | } | |
1136 | ||
1137 | ||
1138 | void | |
1139 | gfc_resolve_sin (gfc_expr * f, gfc_expr * x) | |
1140 | { | |
1141 | ||
1142 | f->ts = x->ts; | |
1143 | f->value.function.name = | |
1144 | gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
1145 | } | |
1146 | ||
1147 | ||
1148 | void | |
1149 | gfc_resolve_sinh (gfc_expr * f, gfc_expr * x) | |
1150 | { | |
1151 | ||
1152 | f->ts = x->ts; | |
1153 | f->value.function.name = | |
1154 | gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
1155 | } | |
1156 | ||
1157 | ||
1158 | void | |
1159 | gfc_resolve_spacing (gfc_expr * f, gfc_expr * x) | |
1160 | { | |
1161 | ||
1162 | f->ts = x->ts; | |
1163 | f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind); | |
1164 | } | |
1165 | ||
1166 | ||
1167 | void | |
1168 | gfc_resolve_spread (gfc_expr * f, gfc_expr * source, | |
1169 | gfc_expr * dim, | |
1170 | gfc_expr * ncopies) | |
1171 | { | |
1172 | static char spread[] = "__spread"; | |
1173 | ||
1174 | f->ts = source->ts; | |
1175 | f->rank = source->rank + 1; | |
1176 | f->value.function.name = spread; | |
1177 | ||
1178 | gfc_resolve_index (dim, 1); | |
1179 | gfc_resolve_index (ncopies, 1); | |
1180 | } | |
1181 | ||
1182 | ||
1183 | void | |
1184 | gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x) | |
1185 | { | |
1186 | ||
1187 | f->ts = x->ts; | |
1188 | f->value.function.name = | |
1189 | gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
1190 | } | |
1191 | ||
1192 | ||
1193 | void | |
1194 | gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim, | |
1195 | gfc_expr * mask) | |
1196 | { | |
1197 | ||
1198 | f->ts = array->ts; | |
1199 | ||
1200 | if (dim != NULL) | |
1201 | { | |
1202 | f->rank = array->rank - 1; | |
1203 | gfc_resolve_index (dim, 1); | |
1204 | } | |
1205 | ||
1206 | f->value.function.name = | |
1207 | gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum", | |
1208 | gfc_type_letter (array->ts.type), array->ts.kind); | |
1209 | } | |
1210 | ||
1211 | ||
1212 | void | |
1213 | gfc_resolve_tan (gfc_expr * f, gfc_expr * x) | |
1214 | { | |
1215 | ||
1216 | f->ts = x->ts; | |
1217 | f->value.function.name = | |
1218 | gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
1219 | } | |
1220 | ||
1221 | ||
1222 | void | |
1223 | gfc_resolve_tanh (gfc_expr * f, gfc_expr * x) | |
1224 | { | |
1225 | ||
1226 | f->ts = x->ts; | |
1227 | f->value.function.name = | |
1228 | gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); | |
1229 | } | |
1230 | ||
1231 | ||
1232 | void | |
1233 | gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED, | |
1234 | gfc_expr * mold, gfc_expr * size) | |
1235 | { | |
1236 | /* TODO: Make this do something meaningful. */ | |
1237 | static char transfer0[] = "__transfer0", transfer1[] = "__transfer1"; | |
1238 | ||
1239 | f->ts = mold->ts; | |
1240 | ||
1241 | if (size == NULL && mold->rank == 0) | |
1242 | { | |
1243 | f->rank = 0; | |
1244 | f->value.function.name = transfer0; | |
1245 | } | |
1246 | else | |
1247 | { | |
1248 | f->rank = 1; | |
1249 | f->value.function.name = transfer1; | |
1250 | } | |
1251 | } | |
1252 | ||
1253 | ||
1254 | void | |
1255 | gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix) | |
1256 | { | |
1257 | static char transpose0[] = "__transpose"; | |
1258 | int kind; | |
1259 | ||
1260 | f->ts = matrix->ts; | |
1261 | f->rank = 2; | |
1262 | ||
1263 | switch (matrix->ts.type) | |
1264 | { | |
1265 | case BT_COMPLEX: | |
1266 | kind = matrix->ts.kind * 2; | |
1267 | break; | |
1268 | ||
1269 | case BT_REAL: | |
1270 | case BT_INTEGER: | |
1271 | case BT_LOGICAL: | |
1272 | kind = matrix->ts.kind; | |
1273 | break; | |
1274 | ||
1275 | default: | |
1276 | kind = 0; | |
1277 | break; | |
1278 | ||
1279 | } | |
1280 | ||
1281 | switch (kind) | |
1282 | { | |
1283 | case 4: | |
1284 | case 8: | |
1285 | /* case 16: */ | |
1286 | f->value.function.name = | |
1287 | gfc_get_string ("__transpose_%d", kind); | |
1288 | break; | |
1289 | ||
1290 | default: | |
1291 | f->value.function.name = transpose0; | |
1292 | } | |
1293 | } | |
1294 | ||
1295 | ||
1296 | void | |
1297 | gfc_resolve_trim (gfc_expr * f, gfc_expr * string) | |
1298 | { | |
1299 | ||
1300 | f->ts.type = BT_CHARACTER; | |
1301 | f->ts.kind = string->ts.kind; | |
1302 | f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); | |
1303 | } | |
1304 | ||
1305 | ||
1306 | void | |
1307 | gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, | |
1308 | gfc_expr * dim) | |
1309 | { | |
1310 | static char ubound[] = "__ubound"; | |
1311 | ||
1312 | f->ts.type = BT_INTEGER; | |
1313 | f->ts.kind = gfc_default_integer_kind (); | |
1314 | ||
1315 | f->rank = (dim == NULL) ? 1 : 0; | |
1316 | f->value.function.name = ubound; | |
1317 | } | |
1318 | ||
1319 | ||
1320 | void | |
1321 | gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask, | |
1322 | gfc_expr * field ATTRIBUTE_UNUSED) | |
1323 | { | |
1324 | ||
1325 | f->ts.type = vector->ts.type; | |
1326 | f->ts.kind = vector->ts.kind; | |
1327 | f->rank = mask->rank; | |
1328 | ||
1329 | f->value.function.name = | |
1330 | gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0); | |
1331 | } | |
1332 | ||
1333 | ||
1334 | void | |
1335 | gfc_resolve_verify (gfc_expr * f, gfc_expr * string, | |
1336 | gfc_expr * set ATTRIBUTE_UNUSED, | |
1337 | gfc_expr * back ATTRIBUTE_UNUSED) | |
1338 | { | |
1339 | ||
1340 | f->ts.type = BT_INTEGER; | |
1341 | f->ts.kind = gfc_default_integer_kind (); | |
1342 | f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind); | |
1343 | } | |
1344 | ||
1345 | ||
1346 | /* Intrinsic subroutine resolution. */ | |
1347 | ||
1348 | void | |
1349 | gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED) | |
1350 | { | |
1351 | const char *name; | |
1352 | ||
1353 | name = gfc_get_string (PREFIX("cpu_time_%d"), | |
1354 | c->ext.actual->expr->ts.kind); | |
1355 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1356 | } | |
1357 | ||
1358 | ||
1359 | void | |
1360 | gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED) | |
1361 | { | |
1362 | const char *name; | |
1363 | int kind; | |
1364 | ||
1365 | kind = c->ext.actual->expr->ts.kind; | |
5f251c26 SK |
1366 | if (c->ext.actual->expr->rank == 0) |
1367 | name = gfc_get_string (PREFIX("random_r%d"), kind); | |
1368 | else | |
1369 | name = gfc_get_string (PREFIX("arandom_r%d"), kind); | |
1370 | ||
6de9cd9a | 1371 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); |
2bd74949 SK |
1372 | |
1373 | } | |
1374 | ||
1375 | ||
1376 | /* G77 compatibility subroutines etime() and dtime(). */ | |
1377 | ||
1378 | void | |
1379 | gfc_resolve_etime_sub (gfc_code * c) | |
1380 | { | |
1381 | const char *name; | |
1382 | ||
1383 | name = gfc_get_string (PREFIX("etime_sub")); | |
1384 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1385 | } | |
1386 | ||
1387 | ||
1388 | /* G77 compatibility subroutine second(). */ | |
1389 | ||
1390 | void | |
1391 | gfc_resolve_second_sub (gfc_code * c) | |
1392 | { | |
1393 | const char *name; | |
1394 | ||
1395 | name = gfc_get_string (PREFIX("second_sub")); | |
1396 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1397 | } | |
1398 | ||
1399 | ||
1400 | /* G77 compatibility function srand(). */ | |
1401 | ||
1402 | void | |
1403 | gfc_resolve_srand (gfc_code * c) | |
1404 | { | |
1405 | const char *name; | |
1406 | name = gfc_get_string (PREFIX("srand")); | |
1407 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
6de9cd9a DN |
1408 | } |
1409 | ||
5f251c26 | 1410 | |
b41b2534 JB |
1411 | /* Resolve the getarg intrinsic subroutine. */ |
1412 | ||
1413 | void | |
1414 | gfc_resolve_getarg (gfc_code * c) | |
1415 | { | |
1416 | const char *name; | |
1417 | int kind; | |
1418 | ||
1419 | kind = gfc_default_integer_kind (); | |
1420 | name = gfc_get_string (PREFIX("getarg_i%d"), kind); | |
1421 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1422 | } | |
1423 | ||
1424 | ||
1425 | /* Resolve the get_command intrinsic subroutine. */ | |
1426 | ||
1427 | void | |
1428 | gfc_resolve_get_command (gfc_code * c) | |
1429 | { | |
1430 | const char *name; | |
1431 | int kind; | |
1432 | ||
1433 | kind = gfc_default_integer_kind (); | |
1434 | name = gfc_get_string (PREFIX("get_command_i%d"), kind); | |
1435 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1436 | } | |
1437 | ||
1438 | ||
1439 | /* Resolve the get_command_argument intrinsic subroutine. */ | |
1440 | ||
1441 | void | |
1442 | gfc_resolve_get_command_argument (gfc_code * c) | |
1443 | { | |
1444 | const char *name; | |
1445 | int kind; | |
1446 | ||
1447 | kind = gfc_default_integer_kind (); | |
1448 | name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind); | |
1449 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1450 | } | |
1451 | ||
aa6fc635 JB |
1452 | /* Resolve the get_environment_variable intrinsic subroutine. */ |
1453 | ||
1454 | void | |
1455 | gfc_resolve_get_environment_variable (gfc_code * code) | |
1456 | { | |
1457 | const char *name; | |
1458 | int kind; | |
1459 | ||
1460 | kind = gfc_default_integer_kind(); | |
1461 | name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind); | |
1462 | code->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1463 | } | |
1464 | ||
b41b2534 | 1465 | |
21fdfcc1 SK |
1466 | /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */ |
1467 | ||
1468 | void | |
1469 | gfc_resolve_system_clock (gfc_code * c) | |
1470 | { | |
1471 | const char *name; | |
1472 | int kind; | |
1473 | ||
1474 | if (c->ext.actual->expr != NULL) | |
1475 | kind = c->ext.actual->expr->ts.kind; | |
1476 | else if (c->ext.actual->next->expr != NULL) | |
1477 | kind = c->ext.actual->next->expr->ts.kind; | |
1478 | else if (c->ext.actual->next->next->expr != NULL) | |
1479 | kind = c->ext.actual->next->next->expr->ts.kind; | |
1480 | else | |
1481 | kind = gfc_default_integer_kind (); | |
1482 | ||
1483 | name = gfc_get_string (PREFIX("system_clock_%d"), kind); | |
1484 | c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); | |
1485 | } | |
1486 | ||
6de9cd9a DN |
1487 | void |
1488 | gfc_iresolve_init_1 (void) | |
1489 | { | |
1490 | int i; | |
1491 | ||
1492 | for (i = 0; i < HASH_SIZE; i++) | |
1493 | string_head[i] = NULL; | |
1494 | } | |
1495 | ||
1496 | ||
1497 | void | |
1498 | gfc_iresolve_done_1 (void) | |
1499 | { | |
1500 | ||
1501 | free_strings (); | |
1502 | } |