]>
Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | /* GDB/Scheme support for math operations on values. |
2 | ||
213516ef | 3 | Copyright (C) 2008-2023 Free Software Foundation, Inc. |
ed3ef339 DE |
4 | |
5 | This file is part of GDB. | |
6 | ||
7 | This program is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
9 | the Free Software Foundation; either version 3 of the License, or | |
10 | (at your option) any later version. | |
11 | ||
12 | This program is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | GNU General Public License for more details. | |
16 | ||
17 | You should have received a copy of the GNU General Public License | |
18 | along with this program. If not, see <http://www.gnu.org/licenses/>. */ | |
19 | ||
20 | /* See README file in this directory for implementation notes, coding | |
21 | conventions, et.al. */ | |
22 | ||
23 | #include "defs.h" | |
24 | #include "arch-utils.h" | |
25 | #include "charset.h" | |
26 | #include "cp-abi.h" | |
14ad9311 | 27 | #include "target-float.h" |
ef0f16cc | 28 | #include "symtab.h" |
ed3ef339 DE |
29 | #include "language.h" |
30 | #include "valprint.h" | |
31 | #include "value.h" | |
32 | #include "guile-internal.h" | |
33 | ||
34 | /* Note: Use target types here to remain consistent with the values system in | |
35 | GDB (which uses target arithmetic). */ | |
36 | ||
37 | enum valscm_unary_opcode | |
38 | { | |
39 | VALSCM_NOT, | |
40 | VALSCM_NEG, | |
41 | VALSCM_NOP, | |
42 | VALSCM_ABS, | |
43 | /* Note: This is Scheme's "logical not", not GDB's. | |
44 | GDB calls this UNOP_COMPLEMENT. */ | |
45 | VALSCM_LOGNOT | |
46 | }; | |
47 | ||
48 | enum valscm_binary_opcode | |
49 | { | |
50 | VALSCM_ADD, | |
51 | VALSCM_SUB, | |
52 | VALSCM_MUL, | |
53 | VALSCM_DIV, | |
54 | VALSCM_REM, | |
55 | VALSCM_MOD, | |
56 | VALSCM_POW, | |
57 | VALSCM_LSH, | |
58 | VALSCM_RSH, | |
59 | VALSCM_MIN, | |
60 | VALSCM_MAX, | |
61 | VALSCM_BITAND, | |
62 | VALSCM_BITOR, | |
63 | VALSCM_BITXOR | |
64 | }; | |
65 | ||
66 | /* If TYPE is a reference, return the target; otherwise return TYPE. */ | |
67 | #define STRIP_REFERENCE(TYPE) \ | |
27710edb | 68 | ((TYPE->code () == TYPE_CODE_REF) ? ((TYPE)->target_type ()) : (TYPE)) |
ed3ef339 | 69 | |
557e56be PA |
70 | /* Helper for vlscm_unop. Contains all the code that may throw a GDB |
71 | exception. */ | |
ed3ef339 DE |
72 | |
73 | static SCM | |
557e56be PA |
74 | vlscm_unop_gdbthrow (enum valscm_unary_opcode opcode, SCM x, |
75 | const char *func_name) | |
ed3ef339 DE |
76 | { |
77 | struct gdbarch *gdbarch = get_current_arch (); | |
78 | const struct language_defn *language = current_language; | |
ed3ef339 | 79 | |
557e56be | 80 | scoped_value_mark free_values; |
ed3ef339 | 81 | |
557e56be PA |
82 | SCM except_scm; |
83 | value *arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x, | |
84 | &except_scm, gdbarch, | |
85 | language); | |
ed3ef339 | 86 | if (arg1 == NULL) |
557e56be | 87 | return except_scm; |
ed3ef339 | 88 | |
557e56be PA |
89 | struct value *res_val = NULL; |
90 | ||
91 | switch (opcode) | |
492d29ea | 92 | { |
557e56be PA |
93 | case VALSCM_NOT: |
94 | /* Alas gdb and guile use the opposite meaning for "logical | |
95 | not". */ | |
96 | { | |
97 | struct type *type = language_bool_type (language, gdbarch); | |
98 | res_val | |
99 | = value_from_longest (type, | |
100 | (LONGEST) value_logical_not (arg1)); | |
101 | } | |
102 | break; | |
103 | case VALSCM_NEG: | |
104 | res_val = value_neg (arg1); | |
105 | break; | |
106 | case VALSCM_NOP: | |
107 | /* Seemingly a no-op, but if X was a Scheme value it is now a | |
108 | <gdb:value> object. */ | |
109 | res_val = arg1; | |
110 | break; | |
111 | case VALSCM_ABS: | |
ee7bb294 | 112 | if (value_less (arg1, value::zero (arg1->type (), not_lval))) |
557e56be PA |
113 | res_val = value_neg (arg1); |
114 | else | |
115 | res_val = arg1; | |
116 | break; | |
117 | case VALSCM_LOGNOT: | |
118 | res_val = value_complement (arg1); | |
119 | break; | |
120 | default: | |
121 | gdb_assert_not_reached ("unsupported operation"); | |
492d29ea | 122 | } |
ed3ef339 DE |
123 | |
124 | gdb_assert (res_val != NULL); | |
557e56be PA |
125 | return vlscm_scm_from_value (res_val); |
126 | } | |
ed3ef339 | 127 | |
557e56be PA |
128 | static SCM |
129 | vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name) | |
130 | { | |
131 | return gdbscm_wrap (vlscm_unop_gdbthrow, opcode, x, func_name); | |
ed3ef339 DE |
132 | } |
133 | ||
557e56be PA |
134 | /* Helper for vlscm_binop. Contains all the code that may throw a GDB |
135 | exception. */ | |
ed3ef339 DE |
136 | |
137 | static SCM | |
557e56be PA |
138 | vlscm_binop_gdbthrow (enum valscm_binary_opcode opcode, SCM x, SCM y, |
139 | const char *func_name) | |
ed3ef339 DE |
140 | { |
141 | struct gdbarch *gdbarch = get_current_arch (); | |
142 | const struct language_defn *language = current_language; | |
143 | struct value *arg1, *arg2; | |
ed3ef339 DE |
144 | struct value *res_val = NULL; |
145 | SCM except_scm; | |
ed3ef339 | 146 | |
557e56be | 147 | scoped_value_mark free_values; |
ed3ef339 DE |
148 | |
149 | arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x, | |
150 | &except_scm, gdbarch, language); | |
151 | if (arg1 == NULL) | |
557e56be PA |
152 | return except_scm; |
153 | ||
ed3ef339 DE |
154 | arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y, |
155 | &except_scm, gdbarch, language); | |
156 | if (arg2 == NULL) | |
557e56be | 157 | return except_scm; |
ed3ef339 | 158 | |
557e56be | 159 | switch (opcode) |
ed3ef339 | 160 | { |
557e56be PA |
161 | case VALSCM_ADD: |
162 | { | |
d0c97917 TT |
163 | struct type *ltype = arg1->type (); |
164 | struct type *rtype = arg2->type (); | |
557e56be PA |
165 | |
166 | ltype = check_typedef (ltype); | |
167 | ltype = STRIP_REFERENCE (ltype); | |
168 | rtype = check_typedef (rtype); | |
169 | rtype = STRIP_REFERENCE (rtype); | |
170 | ||
78134374 | 171 | if (ltype->code () == TYPE_CODE_PTR |
557e56be PA |
172 | && is_integral_type (rtype)) |
173 | res_val = value_ptradd (arg1, value_as_long (arg2)); | |
78134374 | 174 | else if (rtype->code () == TYPE_CODE_PTR |
557e56be PA |
175 | && is_integral_type (ltype)) |
176 | res_val = value_ptradd (arg2, value_as_long (arg1)); | |
177 | else | |
178 | res_val = value_binop (arg1, arg2, BINOP_ADD); | |
179 | } | |
180 | break; | |
181 | case VALSCM_SUB: | |
182 | { | |
d0c97917 TT |
183 | struct type *ltype = arg1->type (); |
184 | struct type *rtype = arg2->type (); | |
557e56be PA |
185 | |
186 | ltype = check_typedef (ltype); | |
187 | ltype = STRIP_REFERENCE (ltype); | |
188 | rtype = check_typedef (rtype); | |
189 | rtype = STRIP_REFERENCE (rtype); | |
190 | ||
78134374 SM |
191 | if (ltype->code () == TYPE_CODE_PTR |
192 | && rtype->code () == TYPE_CODE_PTR) | |
ed3ef339 | 193 | { |
557e56be PA |
194 | /* A ptrdiff_t for the target would be preferable here. */ |
195 | res_val | |
196 | = value_from_longest (builtin_type (gdbarch)->builtin_long, | |
197 | value_ptrdiff (arg1, arg2)); | |
ed3ef339 | 198 | } |
78134374 | 199 | else if (ltype->code () == TYPE_CODE_PTR |
557e56be PA |
200 | && is_integral_type (rtype)) |
201 | res_val = value_ptradd (arg1, - value_as_long (arg2)); | |
202 | else | |
203 | res_val = value_binop (arg1, arg2, BINOP_SUB); | |
204 | } | |
205 | break; | |
206 | case VALSCM_MUL: | |
207 | res_val = value_binop (arg1, arg2, BINOP_MUL); | |
208 | break; | |
209 | case VALSCM_DIV: | |
210 | res_val = value_binop (arg1, arg2, BINOP_DIV); | |
211 | break; | |
212 | case VALSCM_REM: | |
213 | res_val = value_binop (arg1, arg2, BINOP_REM); | |
214 | break; | |
215 | case VALSCM_MOD: | |
216 | res_val = value_binop (arg1, arg2, BINOP_MOD); | |
217 | break; | |
218 | case VALSCM_POW: | |
219 | res_val = value_binop (arg1, arg2, BINOP_EXP); | |
220 | break; | |
221 | case VALSCM_LSH: | |
222 | res_val = value_binop (arg1, arg2, BINOP_LSH); | |
223 | break; | |
224 | case VALSCM_RSH: | |
225 | res_val = value_binop (arg1, arg2, BINOP_RSH); | |
226 | break; | |
227 | case VALSCM_MIN: | |
228 | res_val = value_binop (arg1, arg2, BINOP_MIN); | |
229 | break; | |
230 | case VALSCM_MAX: | |
231 | res_val = value_binop (arg1, arg2, BINOP_MAX); | |
232 | break; | |
233 | case VALSCM_BITAND: | |
234 | res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND); | |
235 | break; | |
236 | case VALSCM_BITOR: | |
237 | res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR); | |
238 | break; | |
239 | case VALSCM_BITXOR: | |
240 | res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR); | |
241 | break; | |
242 | default: | |
243 | gdb_assert_not_reached ("unsupported operation"); | |
492d29ea | 244 | } |
ed3ef339 DE |
245 | |
246 | gdb_assert (res_val != NULL); | |
557e56be PA |
247 | return vlscm_scm_from_value (res_val); |
248 | } | |
ed3ef339 | 249 | |
557e56be PA |
250 | /* Returns a value object which is the result of applying the operation |
251 | specified by OPCODE to the given arguments. | |
252 | If there's an error a Scheme exception is thrown. */ | |
ed3ef339 | 253 | |
557e56be PA |
254 | static SCM |
255 | vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y, | |
256 | const char *func_name) | |
257 | { | |
258 | return gdbscm_wrap (vlscm_binop_gdbthrow, opcode, x, y, func_name); | |
ed3ef339 DE |
259 | } |
260 | ||
261 | /* (value-add x y) -> <gdb:value> */ | |
262 | ||
263 | static SCM | |
264 | gdbscm_value_add (SCM x, SCM y) | |
265 | { | |
266 | return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME); | |
267 | } | |
268 | ||
269 | /* (value-sub x y) -> <gdb:value> */ | |
270 | ||
271 | static SCM | |
272 | gdbscm_value_sub (SCM x, SCM y) | |
273 | { | |
274 | return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME); | |
275 | } | |
276 | ||
277 | /* (value-mul x y) -> <gdb:value> */ | |
278 | ||
279 | static SCM | |
280 | gdbscm_value_mul (SCM x, SCM y) | |
281 | { | |
282 | return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME); | |
283 | } | |
284 | ||
285 | /* (value-div x y) -> <gdb:value> */ | |
286 | ||
287 | static SCM | |
288 | gdbscm_value_div (SCM x, SCM y) | |
289 | { | |
290 | return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME); | |
291 | } | |
292 | ||
293 | /* (value-rem x y) -> <gdb:value> */ | |
294 | ||
295 | static SCM | |
296 | gdbscm_value_rem (SCM x, SCM y) | |
297 | { | |
298 | return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME); | |
299 | } | |
300 | ||
301 | /* (value-mod x y) -> <gdb:value> */ | |
302 | ||
303 | static SCM | |
304 | gdbscm_value_mod (SCM x, SCM y) | |
305 | { | |
306 | return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME); | |
307 | } | |
308 | ||
309 | /* (value-pow x y) -> <gdb:value> */ | |
310 | ||
311 | static SCM | |
312 | gdbscm_value_pow (SCM x, SCM y) | |
313 | { | |
314 | return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME); | |
315 | } | |
316 | ||
317 | /* (value-neg x) -> <gdb:value> */ | |
318 | ||
319 | static SCM | |
320 | gdbscm_value_neg (SCM x) | |
321 | { | |
322 | return vlscm_unop (VALSCM_NEG, x, FUNC_NAME); | |
323 | } | |
324 | ||
325 | /* (value-pos x) -> <gdb:value> */ | |
326 | ||
327 | static SCM | |
328 | gdbscm_value_pos (SCM x) | |
329 | { | |
330 | return vlscm_unop (VALSCM_NOP, x, FUNC_NAME); | |
331 | } | |
332 | ||
333 | /* (value-abs x) -> <gdb:value> */ | |
334 | ||
335 | static SCM | |
336 | gdbscm_value_abs (SCM x) | |
337 | { | |
338 | return vlscm_unop (VALSCM_ABS, x, FUNC_NAME); | |
339 | } | |
340 | ||
341 | /* (value-lsh x y) -> <gdb:value> */ | |
342 | ||
343 | static SCM | |
344 | gdbscm_value_lsh (SCM x, SCM y) | |
345 | { | |
346 | return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME); | |
347 | } | |
348 | ||
349 | /* (value-rsh x y) -> <gdb:value> */ | |
350 | ||
351 | static SCM | |
352 | gdbscm_value_rsh (SCM x, SCM y) | |
353 | { | |
354 | return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME); | |
355 | } | |
356 | ||
357 | /* (value-min x y) -> <gdb:value> */ | |
358 | ||
359 | static SCM | |
360 | gdbscm_value_min (SCM x, SCM y) | |
361 | { | |
362 | return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME); | |
363 | } | |
364 | ||
365 | /* (value-max x y) -> <gdb:value> */ | |
366 | ||
367 | static SCM | |
368 | gdbscm_value_max (SCM x, SCM y) | |
369 | { | |
370 | return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME); | |
371 | } | |
372 | ||
373 | /* (value-not x) -> <gdb:value> */ | |
374 | ||
375 | static SCM | |
376 | gdbscm_value_not (SCM x) | |
377 | { | |
378 | return vlscm_unop (VALSCM_NOT, x, FUNC_NAME); | |
379 | } | |
380 | ||
381 | /* (value-lognot x) -> <gdb:value> */ | |
382 | ||
383 | static SCM | |
384 | gdbscm_value_lognot (SCM x) | |
385 | { | |
386 | return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME); | |
387 | } | |
388 | ||
389 | /* (value-logand x y) -> <gdb:value> */ | |
390 | ||
391 | static SCM | |
392 | gdbscm_value_logand (SCM x, SCM y) | |
393 | { | |
394 | return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME); | |
395 | } | |
396 | ||
397 | /* (value-logior x y) -> <gdb:value> */ | |
398 | ||
399 | static SCM | |
400 | gdbscm_value_logior (SCM x, SCM y) | |
401 | { | |
402 | return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME); | |
403 | } | |
404 | ||
405 | /* (value-logxor x y) -> <gdb:value> */ | |
406 | ||
407 | static SCM | |
408 | gdbscm_value_logxor (SCM x, SCM y) | |
409 | { | |
410 | return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME); | |
411 | } | |
412 | ||
413 | /* Utility to perform all value comparisons. | |
414 | If there's an error a Scheme exception is thrown. */ | |
415 | ||
416 | static SCM | |
417 | vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name) | |
418 | { | |
557e56be PA |
419 | return gdbscm_wrap ([=] |
420 | { | |
421 | struct gdbarch *gdbarch = get_current_arch (); | |
422 | const struct language_defn *language = current_language; | |
423 | SCM except_scm; | |
ed3ef339 | 424 | |
557e56be | 425 | scoped_value_mark free_values; |
ed3ef339 | 426 | |
557e56be PA |
427 | value *v1 |
428 | = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x, | |
429 | &except_scm, gdbarch, language); | |
430 | if (v1 == NULL) | |
431 | return except_scm; | |
ed3ef339 | 432 | |
557e56be PA |
433 | value *v2 |
434 | = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y, | |
435 | &except_scm, gdbarch, language); | |
436 | if (v2 == NULL) | |
437 | return except_scm; | |
438 | ||
439 | int result; | |
ed3ef339 DE |
440 | switch (op) |
441 | { | |
dda83cd7 | 442 | case BINOP_LESS: |
ed3ef339 DE |
443 | result = value_less (v1, v2); |
444 | break; | |
445 | case BINOP_LEQ: | |
446 | result = (value_less (v1, v2) | |
447 | || value_equal (v1, v2)); | |
448 | break; | |
449 | case BINOP_EQUAL: | |
450 | result = value_equal (v1, v2); | |
451 | break; | |
452 | case BINOP_NOTEQUAL: | |
453 | gdb_assert_not_reached ("not-equal not implemented"); | |
dda83cd7 | 454 | case BINOP_GTR: |
ed3ef339 DE |
455 | result = value_less (v2, v1); |
456 | break; | |
457 | case BINOP_GEQ: | |
458 | result = (value_less (v2, v1) | |
459 | || value_equal (v1, v2)); | |
460 | break; | |
461 | default: | |
462 | gdb_assert_not_reached ("invalid <gdb:value> comparison"); | |
557e56be PA |
463 | } |
464 | return scm_from_bool (result); | |
465 | }); | |
ed3ef339 DE |
466 | } |
467 | ||
468 | /* (value=? x y) -> boolean | |
469 | There is no "not-equal?" function (value!= ?) on purpose. | |
470 | We're following string=?, etc. as our Guide here. */ | |
471 | ||
472 | static SCM | |
473 | gdbscm_value_eq_p (SCM x, SCM y) | |
474 | { | |
475 | return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME); | |
476 | } | |
477 | ||
478 | /* (value<? x y) -> boolean */ | |
479 | ||
480 | static SCM | |
481 | gdbscm_value_lt_p (SCM x, SCM y) | |
482 | { | |
483 | return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME); | |
484 | } | |
485 | ||
486 | /* (value<=? x y) -> boolean */ | |
487 | ||
488 | static SCM | |
489 | gdbscm_value_le_p (SCM x, SCM y) | |
490 | { | |
491 | return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME); | |
492 | } | |
493 | ||
494 | /* (value>? x y) -> boolean */ | |
495 | ||
496 | static SCM | |
497 | gdbscm_value_gt_p (SCM x, SCM y) | |
498 | { | |
499 | return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME); | |
500 | } | |
501 | ||
502 | /* (value>=? x y) -> boolean */ | |
503 | ||
504 | static SCM | |
505 | gdbscm_value_ge_p (SCM x, SCM y) | |
506 | { | |
507 | return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME); | |
508 | } | |
509 | \f | |
510 | /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. | |
511 | Convert OBJ, a Scheme number, to a <gdb:value> object. | |
512 | OBJ_ARG_POS is its position in the argument list, used in exception text. | |
513 | ||
514 | TYPE is the result type. TYPE_ARG_POS is its position in | |
515 | the argument list, used in exception text. | |
516 | TYPE_SCM is Scheme object wrapping TYPE, used in exception text. | |
517 | ||
518 | If the number isn't representable, e.g. it's too big, a <gdb:exception> | |
519 | object is stored in *EXCEPT_SCMP and NULL is returned. | |
520 | The conversion may throw a gdb error, e.g., if TYPE is invalid. */ | |
521 | ||
522 | static struct value * | |
523 | vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj, | |
524 | int type_arg_pos, SCM type_scm, struct type *type, | |
525 | struct gdbarch *gdbarch, SCM *except_scmp) | |
526 | { | |
b5b591a8 | 527 | if (is_integral_type (type)) |
ed3ef339 | 528 | { |
c6d940a9 | 529 | if (type->is_unsigned ()) |
ed3ef339 | 530 | { |
c3c1e645 | 531 | ULONGEST max = get_unsigned_type_max (type); |
ed3ef339 DE |
532 | if (!scm_is_unsigned_integer (obj, 0, max)) |
533 | { | |
534 | *except_scmp | |
91ef1ea5 GB |
535 | = gdbscm_make_out_of_range_error |
536 | (func_name, obj_arg_pos, obj, | |
537 | _("value out of range for type")); | |
ed3ef339 DE |
538 | return NULL; |
539 | } | |
540 | return value_from_longest (type, gdbscm_scm_to_ulongest (obj)); | |
541 | } | |
542 | else | |
543 | { | |
544 | LONGEST min, max; | |
545 | ||
546 | get_signed_type_minmax (type, &min, &max); | |
547 | if (!scm_is_signed_integer (obj, min, max)) | |
548 | { | |
549 | *except_scmp | |
91ef1ea5 GB |
550 | = gdbscm_make_out_of_range_error |
551 | (func_name, obj_arg_pos, obj, | |
552 | _("value out of range for type")); | |
ed3ef339 DE |
553 | return NULL; |
554 | } | |
555 | return value_from_longest (type, gdbscm_scm_to_longest (obj)); | |
556 | } | |
557 | } | |
b5b591a8 GB |
558 | else if (type->code () == TYPE_CODE_PTR) |
559 | { | |
560 | CORE_ADDR max = get_pointer_type_max (type); | |
561 | if (!scm_is_unsigned_integer (obj, 0, max)) | |
562 | { | |
563 | *except_scmp | |
91ef1ea5 | 564 | = gdbscm_make_out_of_range_error |
287de656 | 565 | (func_name, obj_arg_pos, obj, |
91ef1ea5 | 566 | _("value out of range for type")); |
b5b591a8 GB |
567 | return NULL; |
568 | } | |
569 | return value_from_pointer (type, gdbscm_scm_to_ulongest (obj)); | |
570 | } | |
78134374 | 571 | else if (type->code () == TYPE_CODE_FLT) |
7584bb30 | 572 | return value_from_host_double (type, scm_to_double (obj)); |
ed3ef339 DE |
573 | else |
574 | { | |
575 | *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj, | |
576 | NULL); | |
577 | return NULL; | |
578 | } | |
579 | } | |
580 | ||
581 | /* Return non-zero if OBJ, an integer, fits in TYPE. */ | |
582 | ||
583 | static int | |
584 | vlscm_integer_fits_p (SCM obj, struct type *type) | |
585 | { | |
c6d940a9 | 586 | if (type->is_unsigned ()) |
ed3ef339 | 587 | { |
ed3ef339 | 588 | /* If scm_is_unsigned_integer can't work with this type, just punt. */ |
df86565b | 589 | if (type->length () > sizeof (uintmax_t)) |
ed3ef339 | 590 | return 0; |
c3c1e645 GB |
591 | |
592 | ULONGEST max = get_unsigned_type_max (type); | |
ed3ef339 DE |
593 | return scm_is_unsigned_integer (obj, 0, max); |
594 | } | |
595 | else | |
596 | { | |
597 | LONGEST min, max; | |
598 | ||
599 | /* If scm_is_signed_integer can't work with this type, just punt. */ | |
df86565b | 600 | if (type->length () > sizeof (intmax_t)) |
ed3ef339 DE |
601 | return 0; |
602 | get_signed_type_minmax (type, &min, &max); | |
603 | return scm_is_signed_integer (obj, min, max); | |
604 | } | |
605 | } | |
606 | ||
607 | /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. | |
608 | Convert OBJ, a Scheme number, to a <gdb:value> object. | |
609 | OBJ_ARG_POS is its position in the argument list, used in exception text. | |
610 | ||
611 | If OBJ is an integer, then the smallest int that will hold the value in | |
612 | the following progression is chosen: | |
613 | int, unsigned int, long, unsigned long, long long, unsigned long long. | |
614 | Otherwise, if OBJ is a real number, then it is converted to a double. | |
615 | Otherwise an exception is thrown. | |
616 | ||
617 | If the number isn't representable, e.g. it's too big, a <gdb:exception> | |
618 | object is stored in *EXCEPT_SCMP and NULL is returned. */ | |
619 | ||
620 | static struct value * | |
621 | vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj, | |
622 | struct gdbarch *gdbarch, SCM *except_scmp) | |
623 | { | |
624 | const struct builtin_type *bt = builtin_type (gdbarch); | |
625 | ||
626 | /* One thing to keep in mind here is that we are interested in the | |
627 | target's representation of OBJ, not the host's. */ | |
628 | ||
629 | if (scm_is_exact (obj) && scm_is_integer (obj)) | |
630 | { | |
631 | if (vlscm_integer_fits_p (obj, bt->builtin_int)) | |
632 | return value_from_longest (bt->builtin_int, | |
633 | gdbscm_scm_to_longest (obj)); | |
634 | if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int)) | |
635 | return value_from_longest (bt->builtin_unsigned_int, | |
636 | gdbscm_scm_to_ulongest (obj)); | |
637 | if (vlscm_integer_fits_p (obj, bt->builtin_long)) | |
638 | return value_from_longest (bt->builtin_long, | |
639 | gdbscm_scm_to_longest (obj)); | |
640 | if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long)) | |
641 | return value_from_longest (bt->builtin_unsigned_long, | |
642 | gdbscm_scm_to_ulongest (obj)); | |
643 | if (vlscm_integer_fits_p (obj, bt->builtin_long_long)) | |
644 | return value_from_longest (bt->builtin_long_long, | |
645 | gdbscm_scm_to_longest (obj)); | |
646 | if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long)) | |
647 | return value_from_longest (bt->builtin_unsigned_long_long, | |
648 | gdbscm_scm_to_ulongest (obj)); | |
649 | } | |
650 | else if (scm_is_real (obj)) | |
7584bb30 | 651 | return value_from_host_double (bt->builtin_double, scm_to_double (obj)); |
ed3ef339 DE |
652 | |
653 | *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj, | |
654 | _("value not a number representable on the target")); | |
655 | return NULL; | |
656 | } | |
657 | ||
658 | /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. | |
659 | Convert BV, a Scheme bytevector, to a <gdb:value> object. | |
660 | ||
661 | TYPE, if non-NULL, is the result type. Otherwise, a vector of type | |
662 | uint8_t is used. | |
663 | TYPE_SCM is Scheme object wrapping TYPE, used in exception text, | |
664 | or #f if TYPE is NULL. | |
665 | ||
666 | If the bytevector isn't the same size as the type, then a <gdb:exception> | |
667 | object is stored in *EXCEPT_SCMP, and NULL is returned. */ | |
668 | ||
669 | static struct value * | |
670 | vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm, | |
671 | int arg_pos, const char *func_name, | |
672 | SCM *except_scmp, struct gdbarch *gdbarch) | |
673 | { | |
674 | LONGEST length = SCM_BYTEVECTOR_LENGTH (bv); | |
675 | struct value *value; | |
676 | ||
677 | if (type == NULL) | |
678 | { | |
679 | type = builtin_type (gdbarch)->builtin_uint8; | |
680 | type = lookup_array_range_type (type, 0, length); | |
681 | make_vector_type (type); | |
682 | } | |
683 | type = check_typedef (type); | |
df86565b | 684 | if (type->length () != length) |
ed3ef339 DE |
685 | { |
686 | *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos, | |
687 | type_scm, | |
688 | _("size of type does not match size of bytevector")); | |
689 | return NULL; | |
690 | } | |
691 | ||
692 | value = value_from_contents (type, | |
693 | (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv)); | |
694 | return value; | |
695 | } | |
696 | ||
697 | /* Convert OBJ, a Scheme value, to a <gdb:value> object. | |
698 | OBJ_ARG_POS is its position in the argument list, used in exception text. | |
699 | ||
700 | TYPE, if non-NULL, is the result type which must be compatible with | |
701 | the value being converted. | |
702 | If TYPE is NULL then a suitable default type is chosen. | |
703 | TYPE_SCM is Scheme object wrapping TYPE, used in exception text, | |
704 | or SCM_UNDEFINED if TYPE is NULL. | |
705 | TYPE_ARG_POS is its position in the argument list, used in exception text, | |
706 | or -1 if TYPE is NULL. | |
707 | ||
708 | OBJ may also be a <gdb:value> object, in which case a copy is returned | |
709 | and TYPE must be NULL. | |
710 | ||
711 | If the value cannot be converted, NULL is returned and a gdb:exception | |
712 | object is stored in *EXCEPT_SCMP. | |
713 | Otherwise the new value is returned, added to the all_values chain. */ | |
714 | ||
715 | struct value * | |
716 | vlscm_convert_typed_value_from_scheme (const char *func_name, | |
717 | int obj_arg_pos, SCM obj, | |
718 | int type_arg_pos, SCM type_scm, | |
719 | struct type *type, | |
720 | SCM *except_scmp, | |
721 | struct gdbarch *gdbarch, | |
722 | const struct language_defn *language) | |
723 | { | |
724 | struct value *value = NULL; | |
725 | SCM except_scm = SCM_BOOL_F; | |
ed3ef339 DE |
726 | |
727 | if (type == NULL) | |
728 | { | |
729 | gdb_assert (type_arg_pos == -1); | |
730 | gdb_assert (SCM_UNBNDP (type_scm)); | |
731 | } | |
732 | ||
733 | *except_scmp = SCM_BOOL_F; | |
734 | ||
a70b8144 | 735 | try |
ed3ef339 DE |
736 | { |
737 | if (vlscm_is_value (obj)) | |
738 | { | |
739 | if (type != NULL) | |
740 | { | |
741 | except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, | |
742 | type_scm, | |
743 | _("No type allowed")); | |
744 | value = NULL; | |
745 | } | |
746 | else | |
cda03344 | 747 | value = vlscm_scm_to_value (obj)->copy (); |
ed3ef339 DE |
748 | } |
749 | else if (gdbscm_is_true (scm_bytevector_p (obj))) | |
750 | { | |
751 | value = vlscm_convert_bytevector (obj, type, type_scm, | |
752 | obj_arg_pos, func_name, | |
753 | &except_scm, gdbarch); | |
754 | } | |
755 | else if (gdbscm_is_bool (obj)) | |
756 | { | |
757 | if (type != NULL | |
758 | && !is_integral_type (type)) | |
759 | { | |
760 | except_scm = gdbscm_make_type_error (func_name, type_arg_pos, | |
761 | type_scm, NULL); | |
762 | } | |
763 | else | |
764 | { | |
765 | value = value_from_longest (type | |
766 | ? type | |
767 | : language_bool_type (language, | |
768 | gdbarch), | |
769 | gdbscm_is_true (obj)); | |
770 | } | |
771 | } | |
772 | else if (scm_is_number (obj)) | |
773 | { | |
774 | if (type != NULL) | |
775 | { | |
776 | value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj, | |
777 | type_arg_pos, type_scm, type, | |
778 | gdbarch, &except_scm); | |
779 | } | |
780 | else | |
781 | { | |
782 | value = vlscm_convert_number (func_name, obj_arg_pos, obj, | |
783 | gdbarch, &except_scm); | |
784 | } | |
785 | } | |
786 | else if (scm_is_string (obj)) | |
787 | { | |
ed3ef339 | 788 | size_t len; |
ed3ef339 DE |
789 | |
790 | if (type != NULL) | |
791 | { | |
792 | except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, | |
793 | type_scm, | |
794 | _("No type allowed")); | |
795 | value = NULL; | |
796 | } | |
797 | else | |
798 | { | |
799 | /* TODO: Provide option to specify conversion strategy. */ | |
c6c6149a TT |
800 | gdb::unique_xmalloc_ptr<char> s |
801 | = gdbscm_scm_to_string (obj, &len, | |
ed3ef339 DE |
802 | target_charset (gdbarch), |
803 | 0 /*non-strict*/, | |
804 | &except_scm); | |
805 | if (s != NULL) | |
baab3753 | 806 | value = language->value_string (gdbarch, s.get (), len); |
ed3ef339 DE |
807 | else |
808 | value = NULL; | |
809 | } | |
810 | } | |
811 | else if (lsscm_is_lazy_string (obj)) | |
812 | { | |
813 | if (type != NULL) | |
814 | { | |
815 | except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, | |
816 | type_scm, | |
817 | _("No type allowed")); | |
818 | value = NULL; | |
819 | } | |
820 | else | |
821 | { | |
822 | value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos, | |
823 | func_name, | |
824 | &except_scm); | |
825 | } | |
826 | } | |
827 | else /* OBJ isn't anything we support. */ | |
828 | { | |
829 | except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj, | |
830 | NULL); | |
831 | value = NULL; | |
832 | } | |
833 | } | |
230d2906 | 834 | catch (const gdb_exception &except) |
492d29ea | 835 | { |
680d7fd5 | 836 | except_scm = gdbscm_scm_from_gdb_exception (unpack (except)); |
492d29ea | 837 | } |
ed3ef339 DE |
838 | |
839 | if (gdbscm_is_true (except_scm)) | |
840 | { | |
841 | gdb_assert (value == NULL); | |
842 | *except_scmp = except_scm; | |
843 | } | |
844 | ||
845 | return value; | |
846 | } | |
847 | ||
848 | /* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there | |
849 | is no supplied type. See vlscm_convert_typed_value_from_scheme for | |
850 | details. */ | |
851 | ||
852 | struct value * | |
853 | vlscm_convert_value_from_scheme (const char *func_name, | |
854 | int obj_arg_pos, SCM obj, | |
855 | SCM *except_scmp, struct gdbarch *gdbarch, | |
856 | const struct language_defn *language) | |
857 | { | |
858 | return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj, | |
859 | -1, SCM_UNDEFINED, NULL, | |
860 | except_scmp, | |
861 | gdbarch, language); | |
862 | } | |
863 | \f | |
864 | /* Initialize value math support. */ | |
865 | ||
866 | static const scheme_function math_functions[] = | |
867 | { | |
72e02483 | 868 | { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add), |
ed3ef339 DE |
869 | "\ |
870 | Return a + b." }, | |
871 | ||
72e02483 | 872 | { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub), |
ed3ef339 DE |
873 | "\ |
874 | Return a - b." }, | |
875 | ||
72e02483 | 876 | { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul), |
ed3ef339 DE |
877 | "\ |
878 | Return a * b." }, | |
879 | ||
72e02483 | 880 | { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div), |
ed3ef339 DE |
881 | "\ |
882 | Return a / b." }, | |
883 | ||
72e02483 | 884 | { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem), |
ed3ef339 DE |
885 | "\ |
886 | Return a % b." }, | |
887 | ||
72e02483 | 888 | { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod), |
ed3ef339 DE |
889 | "\ |
890 | Return a mod b. See Knuth 1.2.4." }, | |
891 | ||
72e02483 | 892 | { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow), |
ed3ef339 DE |
893 | "\ |
894 | Return pow (x, y)." }, | |
895 | ||
72e02483 | 896 | { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not), |
ed3ef339 DE |
897 | "\ |
898 | Return !a." }, | |
899 | ||
72e02483 | 900 | { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg), |
ed3ef339 DE |
901 | "\ |
902 | Return -a." }, | |
903 | ||
72e02483 | 904 | { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos), |
ed3ef339 DE |
905 | "\ |
906 | Return a." }, | |
907 | ||
72e02483 | 908 | { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs), |
ed3ef339 DE |
909 | "\ |
910 | Return abs (a)." }, | |
911 | ||
72e02483 | 912 | { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh), |
ed3ef339 DE |
913 | "\ |
914 | Return a << b." }, | |
915 | ||
72e02483 | 916 | { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh), |
ed3ef339 DE |
917 | "\ |
918 | Return a >> b." }, | |
919 | ||
72e02483 | 920 | { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min), |
ed3ef339 DE |
921 | "\ |
922 | Return min (a, b)." }, | |
923 | ||
72e02483 | 924 | { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max), |
ed3ef339 DE |
925 | "\ |
926 | Return max (a, b)." }, | |
927 | ||
72e02483 | 928 | { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot), |
ed3ef339 DE |
929 | "\ |
930 | Return ~a." }, | |
931 | ||
72e02483 | 932 | { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand), |
ed3ef339 DE |
933 | "\ |
934 | Return a & b." }, | |
935 | ||
72e02483 | 936 | { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior), |
ed3ef339 DE |
937 | "\ |
938 | Return a | b." }, | |
939 | ||
72e02483 | 940 | { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor), |
ed3ef339 DE |
941 | "\ |
942 | Return a ^ b." }, | |
943 | ||
72e02483 | 944 | { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p), |
ed3ef339 DE |
945 | "\ |
946 | Return a == b." }, | |
947 | ||
72e02483 | 948 | { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p), |
ed3ef339 DE |
949 | "\ |
950 | Return a < b." }, | |
951 | ||
72e02483 | 952 | { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p), |
ed3ef339 DE |
953 | "\ |
954 | Return a <= b." }, | |
955 | ||
72e02483 | 956 | { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p), |
ed3ef339 DE |
957 | "\ |
958 | Return a > b." }, | |
959 | ||
72e02483 | 960 | { "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p), |
ed3ef339 DE |
961 | "\ |
962 | Return a >= b." }, | |
963 | ||
964 | END_FUNCTIONS | |
965 | }; | |
966 | ||
967 | void | |
968 | gdbscm_initialize_math (void) | |
969 | { | |
970 | gdbscm_define_functions (math_functions, 1); | |
971 | } |