1 /* GDB/Scheme support for math operations on values. 2 3 Copyright (C) 2008-2016 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 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 97 TRY 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 } 130 CATCH (except, RETURN_MASK_ALL) 131 { 132 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups); 133 } 134 END_CATCH 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; 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 180 TRY 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 189 ltype = check_typedef (ltype); 190 ltype = STRIP_REFERENCE (ltype); 191 rtype = check_typedef (rtype); 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 209 ltype = check_typedef (ltype); 210 ltype = STRIP_REFERENCE (ltype); 211 rtype = check_typedef (rtype); 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 } 269 CATCH (except, RETURN_MASK_ALL) 270 { 271 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups); 272 } 273 END_CATCH 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; 450 struct gdb_exception except = exception_none; 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 469 TRY 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 } 496 CATCH (ex, RETURN_MASK_ALL) 497 { 498 except = ex; 499 } 500 END_CATCH 501 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 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; 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 766 TRY 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 } 873 CATCH (except, RETURN_MASK_ALL) 874 { 875 except_scm = gdbscm_scm_from_gdb_exception (except); 876 } 877 END_CATCH 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 904 /* Initialize value math support. */ 905 906 static const scheme_function math_functions[] = 907 { 908 { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add), 909 "\ 910 Return a + b." }, 911 912 { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub), 913 "\ 914 Return a - b." }, 915 916 { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul), 917 "\ 918 Return a * b." }, 919 920 { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div), 921 "\ 922 Return a / b." }, 923 924 { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem), 925 "\ 926 Return a % b." }, 927 928 { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod), 929 "\ 930 Return a mod b. See Knuth 1.2.4." }, 931 932 { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow), 933 "\ 934 Return pow (x, y)." }, 935 936 { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not), 937 "\ 938 Return !a." }, 939 940 { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg), 941 "\ 942 Return -a." }, 943 944 { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos), 945 "\ 946 Return a." }, 947 948 { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs), 949 "\ 950 Return abs (a)." }, 951 952 { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh), 953 "\ 954 Return a << b." }, 955 956 { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh), 957 "\ 958 Return a >> b." }, 959 960 { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min), 961 "\ 962 Return min (a, b)." }, 963 964 { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max), 965 "\ 966 Return max (a, b)." }, 967 968 { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot), 969 "\ 970 Return ~a." }, 971 972 { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand), 973 "\ 974 Return a & b." }, 975 976 { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior), 977 "\ 978 Return a | b." }, 979 980 { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor), 981 "\ 982 Return a ^ b." }, 983 984 { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p), 985 "\ 986 Return a == b." }, 987 988 { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p), 989 "\ 990 Return a < b." }, 991 992 { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p), 993 "\ 994 Return a <= b." }, 995 996 { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p), 997 "\ 998 Return a > b." }, 999 1000 { "value>=?", 2, 0, 0, as_a_scm_t_subr (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 } 1012