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