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