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