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