gdb/guile/scm-math.c

   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 \f
 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 \f
 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 }