1 /* GDB/Scheme support for math operations on values. 2 3 Copyright (C) 2008-2019 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 "target-float.h" 28 #include "symtab.h" /* Needed by language.h. */ 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) \ 68 ((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE)) 69 70 /* Helper for vlscm_unop. Contains all the code that may throw a GDB 71 exception. */ 72 73 static SCM 74 vlscm_unop_gdbthrow (enum valscm_unary_opcode opcode, SCM x, 75 const char *func_name) 76 { 77 struct gdbarch *gdbarch = get_current_arch (); 78 const struct language_defn *language = current_language; 79 80 scoped_value_mark free_values; 81 82 SCM except_scm; 83 value *arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x, 84 &except_scm, gdbarch, 85 language); 86 if (arg1 == NULL) 87 return except_scm; 88 89 struct value *res_val = NULL; 90 91 switch (opcode) 92 { 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: 112 if (value_less (arg1, value_zero (value_type (arg1), not_lval))) 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"); 122 } 123 124 gdb_assert (res_val != NULL); 125 return vlscm_scm_from_value (res_val); 126 } 127 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); 132 } 133 134 /* Helper for vlscm_binop. Contains all the code that may throw a GDB 135 exception. */ 136 137 static SCM 138 vlscm_binop_gdbthrow (enum valscm_binary_opcode opcode, SCM x, SCM y, 139 const char *func_name) 140 { 141 struct gdbarch *gdbarch = get_current_arch (); 142 const struct language_defn *language = current_language; 143 struct value *arg1, *arg2; 144 struct value *res_val = NULL; 145 SCM except_scm; 146 147 scoped_value_mark free_values; 148 149 arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x, 150 &except_scm, gdbarch, language); 151 if (arg1 == NULL) 152 return except_scm; 153 154 arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y, 155 &except_scm, gdbarch, language); 156 if (arg2 == NULL) 157 return except_scm; 158 159 switch (opcode) 160 { 161 case VALSCM_ADD: 162 { 163 struct type *ltype = value_type (arg1); 164 struct type *rtype = value_type (arg2); 165 166 ltype = check_typedef (ltype); 167 ltype = STRIP_REFERENCE (ltype); 168 rtype = check_typedef (rtype); 169 rtype = STRIP_REFERENCE (rtype); 170 171 if (TYPE_CODE (ltype) == TYPE_CODE_PTR 172 && is_integral_type (rtype)) 173 res_val = value_ptradd (arg1, value_as_long (arg2)); 174 else if (TYPE_CODE (rtype) == TYPE_CODE_PTR 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 { 183 struct type *ltype = value_type (arg1); 184 struct type *rtype = value_type (arg2); 185 186 ltype = check_typedef (ltype); 187 ltype = STRIP_REFERENCE (ltype); 188 rtype = check_typedef (rtype); 189 rtype = STRIP_REFERENCE (rtype); 190 191 if (TYPE_CODE (ltype) == TYPE_CODE_PTR 192 && TYPE_CODE (rtype) == TYPE_CODE_PTR) 193 { 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)); 198 } 199 else if (TYPE_CODE (ltype) == TYPE_CODE_PTR 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"); 244 } 245 246 gdb_assert (res_val != NULL); 247 return vlscm_scm_from_value (res_val); 248 } 249 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. */ 253 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); 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 { 419 return gdbscm_wrap ([=] 420 { 421 struct gdbarch *gdbarch = get_current_arch (); 422 const struct language_defn *language = current_language; 423 SCM except_scm; 424 425 scoped_value_mark free_values; 426 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; 432 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; 440 switch (op) 441 { 442 case BINOP_LESS: 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"); 454 case BINOP_GTR: 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"); 463 } 464 return scm_from_bool (result); 465 }); 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 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 { 527 if (is_integral_type (type) 528 || TYPE_CODE (type) == TYPE_CODE_PTR) 529 { 530 if (TYPE_UNSIGNED (type)) 531 { 532 ULONGEST max; 533 534 get_unsigned_type_max (type, &max); 535 if (!scm_is_unsigned_integer (obj, 0, max)) 536 { 537 *except_scmp 538 = gdbscm_make_out_of_range_error (func_name, 539 obj_arg_pos, obj, 540 _("value out of range for type")); 541 return NULL; 542 } 543 return value_from_longest (type, gdbscm_scm_to_ulongest (obj)); 544 } 545 else 546 { 547 LONGEST min, max; 548 549 get_signed_type_minmax (type, &min, &max); 550 if (!scm_is_signed_integer (obj, min, max)) 551 { 552 *except_scmp 553 = gdbscm_make_out_of_range_error (func_name, 554 obj_arg_pos, obj, 555 _("value out of range for type")); 556 return NULL; 557 } 558 return value_from_longest (type, gdbscm_scm_to_longest (obj)); 559 } 560 } 561 else if (TYPE_CODE (type) == TYPE_CODE_FLT) 562 { 563 struct value *value = allocate_value (type); 564 target_float_from_host_double (value_contents_raw (value), 565 value_type (value), 566 scm_to_double (obj)); 567 return value; 568 } 569 else 570 { 571 *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj, 572 NULL); 573 return NULL; 574 } 575 } 576 577 /* Return non-zero if OBJ, an integer, fits in TYPE. */ 578 579 static int 580 vlscm_integer_fits_p (SCM obj, struct type *type) 581 { 582 if (TYPE_UNSIGNED (type)) 583 { 584 ULONGEST max; 585 586 /* If scm_is_unsigned_integer can't work with this type, just punt. */ 587 if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax)) 588 return 0; 589 get_unsigned_type_max (type, &max); 590 return scm_is_unsigned_integer (obj, 0, max); 591 } 592 else 593 { 594 LONGEST min, max; 595 596 /* If scm_is_signed_integer can't work with this type, just punt. */ 597 if (TYPE_LENGTH (type) > sizeof (scm_t_intmax)) 598 return 0; 599 get_signed_type_minmax (type, &min, &max); 600 return scm_is_signed_integer (obj, min, max); 601 } 602 } 603 604 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. 605 Convert OBJ, a Scheme number, to a <gdb:value> object. 606 OBJ_ARG_POS is its position in the argument list, used in exception text. 607 608 If OBJ is an integer, then the smallest int that will hold the value in 609 the following progression is chosen: 610 int, unsigned int, long, unsigned long, long long, unsigned long long. 611 Otherwise, if OBJ is a real number, then it is converted to a double. 612 Otherwise an exception is thrown. 613 614 If the number isn't representable, e.g. it's too big, a <gdb:exception> 615 object is stored in *EXCEPT_SCMP and NULL is returned. */ 616 617 static struct value * 618 vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj, 619 struct gdbarch *gdbarch, SCM *except_scmp) 620 { 621 const struct builtin_type *bt = builtin_type (gdbarch); 622 623 /* One thing to keep in mind here is that we are interested in the 624 target's representation of OBJ, not the host's. */ 625 626 if (scm_is_exact (obj) && scm_is_integer (obj)) 627 { 628 if (vlscm_integer_fits_p (obj, bt->builtin_int)) 629 return value_from_longest (bt->builtin_int, 630 gdbscm_scm_to_longest (obj)); 631 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int)) 632 return value_from_longest (bt->builtin_unsigned_int, 633 gdbscm_scm_to_ulongest (obj)); 634 if (vlscm_integer_fits_p (obj, bt->builtin_long)) 635 return value_from_longest (bt->builtin_long, 636 gdbscm_scm_to_longest (obj)); 637 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long)) 638 return value_from_longest (bt->builtin_unsigned_long, 639 gdbscm_scm_to_ulongest (obj)); 640 if (vlscm_integer_fits_p (obj, bt->builtin_long_long)) 641 return value_from_longest (bt->builtin_long_long, 642 gdbscm_scm_to_longest (obj)); 643 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long)) 644 return value_from_longest (bt->builtin_unsigned_long_long, 645 gdbscm_scm_to_ulongest (obj)); 646 } 647 else if (scm_is_real (obj)) 648 { 649 struct value *value = allocate_value (bt->builtin_double); 650 target_float_from_host_double (value_contents_raw (value), 651 value_type (value), 652 scm_to_double (obj)); 653 return value; 654 } 655 656 *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj, 657 _("value not a number representable on the target")); 658 return NULL; 659 } 660 661 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it. 662 Convert BV, a Scheme bytevector, to a <gdb:value> object. 663 664 TYPE, if non-NULL, is the result type. Otherwise, a vector of type 665 uint8_t is used. 666 TYPE_SCM is Scheme object wrapping TYPE, used in exception text, 667 or #f if TYPE is NULL. 668 669 If the bytevector isn't the same size as the type, then a <gdb:exception> 670 object is stored in *EXCEPT_SCMP, and NULL is returned. */ 671 672 static struct value * 673 vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm, 674 int arg_pos, const char *func_name, 675 SCM *except_scmp, struct gdbarch *gdbarch) 676 { 677 LONGEST length = SCM_BYTEVECTOR_LENGTH (bv); 678 struct value *value; 679 680 if (type == NULL) 681 { 682 type = builtin_type (gdbarch)->builtin_uint8; 683 type = lookup_array_range_type (type, 0, length); 684 make_vector_type (type); 685 } 686 type = check_typedef (type); 687 if (TYPE_LENGTH (type) != length) 688 { 689 *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos, 690 type_scm, 691 _("size of type does not match size of bytevector")); 692 return NULL; 693 } 694 695 value = value_from_contents (type, 696 (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv)); 697 return value; 698 } 699 700 /* Convert OBJ, a Scheme value, to a <gdb:value> object. 701 OBJ_ARG_POS is its position in the argument list, used in exception text. 702 703 TYPE, if non-NULL, is the result type which must be compatible with 704 the value being converted. 705 If TYPE is NULL then a suitable default type is chosen. 706 TYPE_SCM is Scheme object wrapping TYPE, used in exception text, 707 or SCM_UNDEFINED if TYPE is NULL. 708 TYPE_ARG_POS is its position in the argument list, used in exception text, 709 or -1 if TYPE is NULL. 710 711 OBJ may also be a <gdb:value> object, in which case a copy is returned 712 and TYPE must be NULL. 713 714 If the value cannot be converted, NULL is returned and a gdb:exception 715 object is stored in *EXCEPT_SCMP. 716 Otherwise the new value is returned, added to the all_values chain. */ 717 718 struct value * 719 vlscm_convert_typed_value_from_scheme (const char *func_name, 720 int obj_arg_pos, SCM obj, 721 int type_arg_pos, SCM type_scm, 722 struct type *type, 723 SCM *except_scmp, 724 struct gdbarch *gdbarch, 725 const struct language_defn *language) 726 { 727 struct value *value = NULL; 728 SCM except_scm = SCM_BOOL_F; 729 730 if (type == NULL) 731 { 732 gdb_assert (type_arg_pos == -1); 733 gdb_assert (SCM_UNBNDP (type_scm)); 734 } 735 736 *except_scmp = SCM_BOOL_F; 737 738 TRY 739 { 740 if (vlscm_is_value (obj)) 741 { 742 if (type != NULL) 743 { 744 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, 745 type_scm, 746 _("No type allowed")); 747 value = NULL; 748 } 749 else 750 value = value_copy (vlscm_scm_to_value (obj)); 751 } 752 else if (gdbscm_is_true (scm_bytevector_p (obj))) 753 { 754 value = vlscm_convert_bytevector (obj, type, type_scm, 755 obj_arg_pos, func_name, 756 &except_scm, gdbarch); 757 } 758 else if (gdbscm_is_bool (obj)) 759 { 760 if (type != NULL 761 && !is_integral_type (type)) 762 { 763 except_scm = gdbscm_make_type_error (func_name, type_arg_pos, 764 type_scm, NULL); 765 } 766 else 767 { 768 value = value_from_longest (type 769 ? type 770 : language_bool_type (language, 771 gdbarch), 772 gdbscm_is_true (obj)); 773 } 774 } 775 else if (scm_is_number (obj)) 776 { 777 if (type != NULL) 778 { 779 value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj, 780 type_arg_pos, type_scm, type, 781 gdbarch, &except_scm); 782 } 783 else 784 { 785 value = vlscm_convert_number (func_name, obj_arg_pos, obj, 786 gdbarch, &except_scm); 787 } 788 } 789 else if (scm_is_string (obj)) 790 { 791 size_t len; 792 793 if (type != NULL) 794 { 795 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, 796 type_scm, 797 _("No type allowed")); 798 value = NULL; 799 } 800 else 801 { 802 /* TODO: Provide option to specify conversion strategy. */ 803 gdb::unique_xmalloc_ptr<char> s 804 = gdbscm_scm_to_string (obj, &len, 805 target_charset (gdbarch), 806 0 /*non-strict*/, 807 &except_scm); 808 if (s != NULL) 809 value = value_cstring (s.get (), len, 810 language_string_char_type (language, 811 gdbarch)); 812 else 813 value = NULL; 814 } 815 } 816 else if (lsscm_is_lazy_string (obj)) 817 { 818 if (type != NULL) 819 { 820 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos, 821 type_scm, 822 _("No type allowed")); 823 value = NULL; 824 } 825 else 826 { 827 value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos, 828 func_name, 829 &except_scm); 830 } 831 } 832 else /* OBJ isn't anything we support. */ 833 { 834 except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj, 835 NULL); 836 value = NULL; 837 } 838 } 839 CATCH (except, RETURN_MASK_ALL) 840 { 841 except_scm = gdbscm_scm_from_gdb_exception (except); 842 } 843 END_CATCH 844 845 if (gdbscm_is_true (except_scm)) 846 { 847 gdb_assert (value == NULL); 848 *except_scmp = except_scm; 849 } 850 851 return value; 852 } 853 854 /* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there 855 is no supplied type. See vlscm_convert_typed_value_from_scheme for 856 details. */ 857 858 struct value * 859 vlscm_convert_value_from_scheme (const char *func_name, 860 int obj_arg_pos, SCM obj, 861 SCM *except_scmp, struct gdbarch *gdbarch, 862 const struct language_defn *language) 863 { 864 return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj, 865 -1, SCM_UNDEFINED, NULL, 866 except_scmp, 867 gdbarch, language); 868 } 869 870 /* Initialize value math support. */ 871 872 static const scheme_function math_functions[] = 873 { 874 { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add), 875 "\ 876 Return a + b." }, 877 878 { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub), 879 "\ 880 Return a - b." }, 881 882 { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul), 883 "\ 884 Return a * b." }, 885 886 { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div), 887 "\ 888 Return a / b." }, 889 890 { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem), 891 "\ 892 Return a % b." }, 893 894 { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod), 895 "\ 896 Return a mod b. See Knuth 1.2.4." }, 897 898 { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow), 899 "\ 900 Return pow (x, y)." }, 901 902 { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not), 903 "\ 904 Return !a." }, 905 906 { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg), 907 "\ 908 Return -a." }, 909 910 { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos), 911 "\ 912 Return a." }, 913 914 { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs), 915 "\ 916 Return abs (a)." }, 917 918 { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh), 919 "\ 920 Return a << b." }, 921 922 { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh), 923 "\ 924 Return a >> b." }, 925 926 { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min), 927 "\ 928 Return min (a, b)." }, 929 930 { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max), 931 "\ 932 Return max (a, b)." }, 933 934 { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot), 935 "\ 936 Return ~a." }, 937 938 { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand), 939 "\ 940 Return a & b." }, 941 942 { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior), 943 "\ 944 Return a | b." }, 945 946 { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor), 947 "\ 948 Return a ^ b." }, 949 950 { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p), 951 "\ 952 Return a == b." }, 953 954 { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p), 955 "\ 956 Return a < b." }, 957 958 { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p), 959 "\ 960 Return a <= b." }, 961 962 { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p), 963 "\ 964 Return a > b." }, 965 966 { "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p), 967 "\ 968 Return a >= b." }, 969 970 END_FUNCTIONS 971 }; 972 973 void 974 gdbscm_initialize_math (void) 975 { 976 gdbscm_define_functions (math_functions, 1); 977 } 978