gdb/guile/scm-math.c

   1 /* GDB/Scheme support for math operations on values.
   2
   3    Copyright (C) 2008-2014 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "arch-utils.h"
  25 #include "charset.h"
  26 #include "cp-abi.h"
  27 #include "doublest.h" /* Needed by dfp.h.  */
  28 #include "expression.h" /* Needed by dfp.h.  */
  29 #include "dfp.h"
  30 #include "symtab.h" /* Needed by language.h.  */
  31 #include "language.h"
  32 #include "valprint.h"
  33 #include "value.h"
  34 #include "guile-internal.h"
  35
  36 /* Note: Use target types here to remain consistent with the values system in
  37    GDB (which uses target arithmetic).  */
  38
  39 enum valscm_unary_opcode
  40 {
  41   VALSCM_NOT,
  42   VALSCM_NEG,
  43   VALSCM_NOP,
  44   VALSCM_ABS,
  45   /* Note: This is Scheme's "logical not", not GDB's.
  46      GDB calls this UNOP_COMPLEMENT.  */
  47   VALSCM_LOGNOT
  48 };
  49
  50 enum valscm_binary_opcode
  51 {
  52   VALSCM_ADD,
  53   VALSCM_SUB,
  54   VALSCM_MUL,
  55   VALSCM_DIV,
  56   VALSCM_REM,
  57   VALSCM_MOD,
  58   VALSCM_POW,
  59   VALSCM_LSH,
  60   VALSCM_RSH,
  61   VALSCM_MIN,
  62   VALSCM_MAX,
  63   VALSCM_BITAND,
  64   VALSCM_BITOR,
  65   VALSCM_BITXOR
  66 };
  67
  68 /* If TYPE is a reference, return the target; otherwise return TYPE.  */
  69 #define STRIP_REFERENCE(TYPE) \
  70   ((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE))
  71
  72 /* Returns a value object which is the result of applying the operation
  73    specified by OPCODE to the given argument.
  74    If there's an error a Scheme exception is thrown.  */
  75
  76 static SCM
  77 vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
  78 {
  79   struct gdbarch *gdbarch = get_current_arch ();
  80   const struct language_defn *language = current_language;
  81   struct value *arg1;
  82   SCM result = SCM_BOOL_F;
  83   struct value *res_val = NULL;
  84   SCM except_scm;
  85   struct cleanup *cleanups;
  86   volatile struct gdb_exception except;
  87
  88   cleanups = make_cleanup_value_free_to_mark (value_mark ());
  89
  90   arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
  91                                           &except_scm, gdbarch, language);
  92   if (arg1 == NULL)
  93     {
  94       do_cleanups (cleanups);
  95       gdbscm_throw (except_scm);
  96     }
  97
  98   TRY_CATCH (except, RETURN_MASK_ALL)
  99     {
 100       switch (opcode)
 101         {
 102         case VALSCM_NOT:
 103           /* Alas gdb and guile use the opposite meaning for "logical not".  */
 104           {
 105             struct type *type = language_bool_type (language, gdbarch);
 106             res_val
 107               = value_from_longest (type, (LONGEST) value_logical_not (arg1));
 108           }
 109           break;
 110         case VALSCM_NEG:
 111           res_val = value_neg (arg1);
 112           break;
 113         case VALSCM_NOP:
 114           /* Seemingly a no-op, but if X was a Scheme value it is now
 115              a <gdb:value> object.  */
 116           res_val = arg1;
 117           break;
 118         case VALSCM_ABS:
 119           if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
 120             res_val = value_neg (arg1);
 121           else
 122             res_val = arg1;
 123           break;
 124         case VALSCM_LOGNOT:
 125           res_val = value_complement (arg1);
 126           break;
 127         default:
 128           gdb_assert_not_reached ("unsupported operation");
 129         }
 130     }
 131   GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 132
 133   gdb_assert (res_val != NULL);
 134   result = vlscm_scm_from_value (res_val);
 135
 136   do_cleanups (cleanups);
 137
 138   if (gdbscm_is_exception (result))
 139     gdbscm_throw (result);
 140
 141   return result;
 142 }
 143
 144 /* Returns a value object which is the result of applying the operation
 145    specified by OPCODE to the given arguments.
 146    If there's an error a Scheme exception is thrown.  */
 147
 148 static SCM
 149 vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
 150              const char *func_name)
 151 {
 152   struct gdbarch *gdbarch = get_current_arch ();
 153   const struct language_defn *language = current_language;
 154   struct value *arg1, *arg2;
 155   SCM result = SCM_BOOL_F;
 156   struct value *res_val = NULL;
 157   SCM except_scm;
 158   struct cleanup *cleanups;
 159   volatile struct gdb_exception except;
 160
 161   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 162
 163   arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
 164                                           &except_scm, gdbarch, language);
 165   if (arg1 == NULL)
 166     {
 167       do_cleanups (cleanups);
 168       gdbscm_throw (except_scm);
 169     }
 170   arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
 171                                           &except_scm, gdbarch, language);
 172   if (arg2 == NULL)
 173     {
 174       do_cleanups (cleanups);
 175       gdbscm_throw (except_scm);
 176     }
 177
 178   TRY_CATCH (except, RETURN_MASK_ALL)
 179     {
 180       switch (opcode)
 181         {
 182         case VALSCM_ADD:
 183           {
 184             struct type *ltype = value_type (arg1);
 185             struct type *rtype = value_type (arg2);
 186
 187             CHECK_TYPEDEF (ltype);
 188             ltype = STRIP_REFERENCE (ltype);
 189             CHECK_TYPEDEF (rtype);
 190             rtype = STRIP_REFERENCE (rtype);
 191
 192             if (TYPE_CODE (ltype) == TYPE_CODE_PTR
 193                 && is_integral_type (rtype))
 194               res_val = value_ptradd (arg1, value_as_long (arg2));
 195             else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
 196                      && is_integral_type (ltype))
 197               res_val = value_ptradd (arg2, value_as_long (arg1));
 198             else
 199               res_val = value_binop (arg1, arg2, BINOP_ADD);
 200           }
 201           break;
 202         case VALSCM_SUB:
 203           {
 204             struct type *ltype = value_type (arg1);
 205             struct type *rtype = value_type (arg2);
 206
 207             CHECK_TYPEDEF (ltype);
 208             ltype = STRIP_REFERENCE (ltype);
 209             CHECK_TYPEDEF (rtype);
 210             rtype = STRIP_REFERENCE (rtype);
 211
 212             if (TYPE_CODE (ltype) == TYPE_CODE_PTR
 213                 && TYPE_CODE (rtype) == TYPE_CODE_PTR)
 214               {
 215                 /* A ptrdiff_t for the target would be preferable here.  */
 216                 res_val
 217                   = value_from_longest (builtin_type (gdbarch)->builtin_long,
 218                                         value_ptrdiff (arg1, arg2));
 219               }
 220             else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
 221                      && is_integral_type (rtype))
 222               res_val = value_ptradd (arg1, - value_as_long (arg2));
 223             else
 224               res_val = value_binop (arg1, arg2, BINOP_SUB);
 225           }
 226           break;
 227         case VALSCM_MUL:
 228           res_val = value_binop (arg1, arg2, BINOP_MUL);
 229           break;
 230         case VALSCM_DIV:
 231           res_val = value_binop (arg1, arg2, BINOP_DIV);
 232           break;
 233         case VALSCM_REM:
 234           res_val = value_binop (arg1, arg2, BINOP_REM);
 235           break;
 236         case VALSCM_MOD:
 237           res_val = value_binop (arg1, arg2, BINOP_MOD);
 238           break;
 239         case VALSCM_POW:
 240           res_val = value_binop (arg1, arg2, BINOP_EXP);
 241           break;
 242         case VALSCM_LSH:
 243           res_val = value_binop (arg1, arg2, BINOP_LSH);
 244           break;
 245         case VALSCM_RSH:
 246           res_val = value_binop (arg1, arg2, BINOP_RSH);
 247           break;
 248         case VALSCM_MIN:
 249           res_val = value_binop (arg1, arg2, BINOP_MIN);
 250           break;
 251         case VALSCM_MAX:
 252           res_val = value_binop (arg1, arg2, BINOP_MAX);
 253           break;
 254         case VALSCM_BITAND:
 255           res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
 256           break;
 257         case VALSCM_BITOR:
 258           res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
 259           break;
 260         case VALSCM_BITXOR:
 261           res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
 262           break;
 263         default:
 264           gdb_assert_not_reached ("unsupported operation");
 265         }
 266     }
 267   GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 268
 269   gdb_assert (res_val != NULL);
 270   result = vlscm_scm_from_value (res_val);
 271
 272   do_cleanups (cleanups);
 273
 274   if (gdbscm_is_exception (result))
 275     gdbscm_throw (result);
 276
 277   return result;
 278 }
 279
 280 /* (value-add x y) -> <gdb:value> */
 281
 282 static SCM
 283 gdbscm_value_add (SCM x, SCM y)
 284 {
 285   return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME);
 286 }
 287
 288 /* (value-sub x y) -> <gdb:value> */
 289
 290 static SCM
 291 gdbscm_value_sub (SCM x, SCM y)
 292 {
 293   return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME);
 294 }
 295
 296 /* (value-mul x y) -> <gdb:value> */
 297
 298 static SCM
 299 gdbscm_value_mul (SCM x, SCM y)
 300 {
 301   return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME);
 302 }
 303
 304 /* (value-div x y) -> <gdb:value> */
 305
 306 static SCM
 307 gdbscm_value_div (SCM x, SCM y)
 308 {
 309   return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME);
 310 }
 311
 312 /* (value-rem x y) -> <gdb:value> */
 313
 314 static SCM
 315 gdbscm_value_rem (SCM x, SCM y)
 316 {
 317   return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME);
 318 }
 319
 320 /* (value-mod x y) -> <gdb:value> */
 321
 322 static SCM
 323 gdbscm_value_mod (SCM x, SCM y)
 324 {
 325   return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME);
 326 }
 327
 328 /* (value-pow x y) -> <gdb:value> */
 329
 330 static SCM
 331 gdbscm_value_pow (SCM x, SCM y)
 332 {
 333   return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME);
 334 }
 335
 336 /* (value-neg x) -> <gdb:value> */
 337
 338 static SCM
 339 gdbscm_value_neg (SCM x)
 340 {
 341   return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
 342 }
 343
 344 /* (value-pos x) -> <gdb:value> */
 345
 346 static SCM
 347 gdbscm_value_pos (SCM x)
 348 {
 349   return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
 350 }
 351
 352 /* (value-abs x) -> <gdb:value> */
 353
 354 static SCM
 355 gdbscm_value_abs (SCM x)
 356 {
 357   return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
 358 }
 359
 360 /* (value-lsh x y) -> <gdb:value> */
 361
 362 static SCM
 363 gdbscm_value_lsh (SCM x, SCM y)
 364 {
 365   return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME);
 366 }
 367
 368 /* (value-rsh x y) -> <gdb:value> */
 369
 370 static SCM
 371 gdbscm_value_rsh (SCM x, SCM y)
 372 {
 373   return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME);
 374 }
 375
 376 /* (value-min x y) -> <gdb:value> */
 377
 378 static SCM
 379 gdbscm_value_min (SCM x, SCM y)
 380 {
 381   return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME);
 382 }
 383
 384 /* (value-max x y) -> <gdb:value> */
 385
 386 static SCM
 387 gdbscm_value_max (SCM x, SCM y)
 388 {
 389   return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME);
 390 }
 391
 392 /* (value-not x) -> <gdb:value> */
 393
 394 static SCM
 395 gdbscm_value_not (SCM x)
 396 {
 397   return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
 398 }
 399
 400 /* (value-lognot x) -> <gdb:value> */
 401
 402 static SCM
 403 gdbscm_value_lognot (SCM x)
 404 {
 405   return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
 406 }
 407
 408 /* (value-logand x y) -> <gdb:value> */
 409
 410 static SCM
 411 gdbscm_value_logand (SCM x, SCM y)
 412 {
 413   return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
 414 }
 415
 416 /* (value-logior x y) -> <gdb:value> */
 417
 418 static SCM
 419 gdbscm_value_logior (SCM x, SCM y)
 420 {
 421   return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
 422 }
 423
 424 /* (value-logxor x y) -> <gdb:value> */
 425
 426 static SCM
 427 gdbscm_value_logxor (SCM x, SCM y)
 428 {
 429   return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME);
 430 }
 431
 432 /* Utility to perform all value comparisons.
 433    If there's an error a Scheme exception is thrown.  */
 434
 435 static SCM
 436 vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
 437 {
 438   struct gdbarch *gdbarch = get_current_arch ();
 439   const struct language_defn *language = current_language;
 440   struct value *v1, *v2;
 441   int result = 0;
 442   SCM except_scm;
 443   struct cleanup *cleanups;
 444   volatile struct gdb_exception except;
 445
 446   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 447
 448   v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
 449                                         &except_scm, gdbarch, language);
 450   if (v1 == NULL)
 451     {
 452       do_cleanups (cleanups);
 453       gdbscm_throw (except_scm);
 454     }
 455   v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
 456                                         &except_scm, gdbarch, language);
 457   if (v2 == NULL)
 458     {
 459       do_cleanups (cleanups);
 460       gdbscm_throw (except_scm);
 461     }
 462
 463   TRY_CATCH (except, RETURN_MASK_ALL)
 464     {
 465       switch (op)
 466         {
 467         case BINOP_LESS:
 468           result = value_less (v1, v2);
 469           break;
 470         case BINOP_LEQ:
 471           result = (value_less (v1, v2)
 472                     || value_equal (v1, v2));
 473           break;
 474         case BINOP_EQUAL:
 475           result = value_equal (v1, v2);
 476           break;
 477         case BINOP_NOTEQUAL:
 478           gdb_assert_not_reached ("not-equal not implemented");
 479         case BINOP_GTR:
 480           result = value_less (v2, v1);
 481           break;
 482         case BINOP_GEQ:
 483           result = (value_less (v2, v1)
 484                     || value_equal (v1, v2));
 485           break;
 486         default:
 487           gdb_assert_not_reached ("invalid <gdb:value> comparison");
 488       }
 489     }
 490   do_cleanups (cleanups);
 491   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 492
 493   return scm_from_bool (result);
 494 }
 495
 496 /* (value=? x y) -> boolean
 497    There is no "not-equal?" function (value!= ?) on purpose.
 498    We're following string=?, etc. as our Guide here.  */
 499
 500 static SCM
 501 gdbscm_value_eq_p (SCM x, SCM y)
 502 {
 503   return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME);
 504 }
 505
 506 /* (value<? x y) -> boolean */
 507
 508 static SCM
 509 gdbscm_value_lt_p (SCM x, SCM y)
 510 {
 511   return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME);
 512 }
 513
 514 /* (value<=? x y) -> boolean */
 515
 516 static SCM
 517 gdbscm_value_le_p (SCM x, SCM y)
 518 {
 519   return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME);
 520 }
 521
 522 /* (value>? x y) -> boolean */
 523
 524 static SCM
 525 gdbscm_value_gt_p (SCM x, SCM y)
 526 {
 527   return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME);
 528 }
 529
 530 /* (value>=? x y) -> boolean */
 531
 532 static SCM
 533 gdbscm_value_ge_p (SCM x, SCM y)
 534 {
 535   return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
 536 }
 537 \f
 538 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 539    Convert OBJ, a Scheme number, to a <gdb:value> object.
 540    OBJ_ARG_POS is its position in the argument list, used in exception text.
 541
 542    TYPE is the result type.  TYPE_ARG_POS is its position in
 543    the argument list, used in exception text.
 544    TYPE_SCM is Scheme object wrapping TYPE, used in exception text.
 545
 546    If the number isn't representable, e.g. it's too big, a <gdb:exception>
 547    object is stored in *EXCEPT_SCMP and NULL is returned.
 548    The conversion may throw a gdb error, e.g., if TYPE is invalid.  */
 549
 550 static struct value *
 551 vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj,
 552                             int type_arg_pos, SCM type_scm, struct type *type,
 553                             struct gdbarch *gdbarch, SCM *except_scmp)
 554 {
 555   if (is_integral_type (type)
 556       || TYPE_CODE (type) == TYPE_CODE_PTR)
 557     {
 558       if (TYPE_UNSIGNED (type))
 559         {
 560           ULONGEST max;
 561
 562           get_unsigned_type_max (type, &max);
 563           if (!scm_is_unsigned_integer (obj, 0, max))
 564             {
 565               *except_scmp
 566                 = gdbscm_make_out_of_range_error (func_name,
 567                                                   obj_arg_pos, obj,
 568                                         _("value out of range for type"));
 569               return NULL;
 570             }
 571           return value_from_longest (type, gdbscm_scm_to_ulongest (obj));
 572         }
 573       else
 574         {
 575           LONGEST min, max;
 576
 577           get_signed_type_minmax (type, &min, &max);
 578           if (!scm_is_signed_integer (obj, min, max))
 579             {
 580               *except_scmp
 581                 = gdbscm_make_out_of_range_error (func_name,
 582                                                   obj_arg_pos, obj,
 583                                         _("value out of range for type"));
 584               return NULL;
 585             }
 586           return value_from_longest (type, gdbscm_scm_to_longest (obj));
 587         }
 588     }
 589   else if (TYPE_CODE (type) == TYPE_CODE_FLT)
 590     return value_from_double (type, scm_to_double (obj));
 591   else
 592     {
 593       *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
 594                                              NULL);
 595       return NULL;
 596     }
 597 }
 598
 599 /* Return non-zero if OBJ, an integer, fits in TYPE.  */
 600
 601 static int
 602 vlscm_integer_fits_p (SCM obj, struct type *type)
 603 {
 604   if (TYPE_UNSIGNED (type))
 605     {
 606       ULONGEST max;
 607
 608       /* If scm_is_unsigned_integer can't work with this type, just punt.  */
 609       if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax))
 610         return 0;
 611       get_unsigned_type_max (type, &max);
 612       return scm_is_unsigned_integer (obj, 0, max);
 613     }
 614   else
 615     {
 616       LONGEST min, max;
 617
 618       /* If scm_is_signed_integer can't work with this type, just punt.  */
 619       if (TYPE_LENGTH (type) > sizeof (scm_t_intmax))
 620         return 0;
 621       get_signed_type_minmax (type, &min, &max);
 622       return scm_is_signed_integer (obj, min, max);
 623     }
 624 }
 625
 626 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 627    Convert OBJ, a Scheme number, to a <gdb:value> object.
 628    OBJ_ARG_POS is its position in the argument list, used in exception text.
 629
 630    If OBJ is an integer, then the smallest int that will hold the value in
 631    the following progression is chosen:
 632    int, unsigned int, long, unsigned long, long long, unsigned long long.
 633    Otherwise, if OBJ is a real number, then it is converted to a double.
 634    Otherwise an exception is thrown.
 635
 636    If the number isn't representable, e.g. it's too big, a <gdb:exception>
 637    object is stored in *EXCEPT_SCMP and NULL is returned.  */
 638
 639 static struct value *
 640 vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
 641                       struct gdbarch *gdbarch, SCM *except_scmp)
 642 {
 643   const struct builtin_type *bt = builtin_type (gdbarch);
 644
 645   /* One thing to keep in mind here is that we are interested in the
 646      target's representation of OBJ, not the host's.  */
 647
 648   if (scm_is_exact (obj) && scm_is_integer (obj))
 649     {
 650       if (vlscm_integer_fits_p (obj, bt->builtin_int))
 651         return value_from_longest (bt->builtin_int,
 652                                    gdbscm_scm_to_longest (obj));
 653       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
 654         return value_from_longest (bt->builtin_unsigned_int,
 655                                    gdbscm_scm_to_ulongest (obj));
 656       if (vlscm_integer_fits_p (obj, bt->builtin_long))
 657         return value_from_longest (bt->builtin_long,
 658                                    gdbscm_scm_to_longest (obj));
 659       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
 660         return value_from_longest (bt->builtin_unsigned_long,
 661                                    gdbscm_scm_to_ulongest (obj));
 662       if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
 663         return value_from_longest (bt->builtin_long_long,
 664                                    gdbscm_scm_to_longest (obj));
 665       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
 666         return value_from_longest (bt->builtin_unsigned_long_long,
 667                                    gdbscm_scm_to_ulongest (obj));
 668     }
 669   else if (scm_is_real (obj))
 670     return value_from_double (bt->builtin_double, scm_to_double (obj));
 671
 672   *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
 673                         _("value not a number representable on the target"));
 674   return NULL;
 675 }
 676
 677 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 678    Convert BV, a Scheme bytevector, to a <gdb:value> object.
 679
 680    TYPE, if non-NULL, is the result type.  Otherwise, a vector of type
 681    uint8_t is used.
 682    TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
 683    or #f if TYPE is NULL.
 684
 685    If the bytevector isn't the same size as the type, then a <gdb:exception>
 686    object is stored in *EXCEPT_SCMP, and NULL is returned.  */
 687
 688 static struct value *
 689 vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
 690                           int arg_pos, const char *func_name,
 691                           SCM *except_scmp, struct gdbarch *gdbarch)
 692 {
 693   LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
 694   struct value *value;
 695
 696   if (type == NULL)
 697     {
 698       type = builtin_type (gdbarch)->builtin_uint8;
 699       type = lookup_array_range_type (type, 0, length);
 700       make_vector_type (type);
 701     }
 702   type = check_typedef (type);
 703   if (TYPE_LENGTH (type) != length)
 704     {
 705       *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
 706                                                      type_scm,
 707                         _("size of type does not match size of bytevector"));
 708       return NULL;
 709     }
 710
 711   value = value_from_contents (type,
 712                                (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
 713   return value;
 714 }
 715
 716 /* Convert OBJ, a Scheme value, to a <gdb:value> object.
 717    OBJ_ARG_POS is its position in the argument list, used in exception text.
 718
 719    TYPE, if non-NULL, is the result type which must be compatible with
 720    the value being converted.
 721    If TYPE is NULL then a suitable default type is chosen.
 722    TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
 723    or SCM_UNDEFINED if TYPE is NULL.
 724    TYPE_ARG_POS is its position in the argument list, used in exception text,
 725    or -1 if TYPE is NULL.
 726
 727    OBJ may also be a <gdb:value> object, in which case a copy is returned
 728    and TYPE must be NULL.
 729
 730    If the value cannot be converted, NULL is returned and a gdb:exception
 731    object is stored in *EXCEPT_SCMP.
 732    Otherwise the new value is returned, added to the all_values chain.  */
 733
 734 struct value *
 735 vlscm_convert_typed_value_from_scheme (const char *func_name,
 736                                        int obj_arg_pos, SCM obj,
 737                                        int type_arg_pos, SCM type_scm,
 738                                        struct type *type,
 739                                        SCM *except_scmp,
 740                                        struct gdbarch *gdbarch,
 741                                        const struct language_defn *language)
 742 {
 743   struct value *value = NULL;
 744   SCM except_scm = SCM_BOOL_F;
 745   volatile struct gdb_exception except;
 746
 747   if (type == NULL)
 748     {
 749       gdb_assert (type_arg_pos == -1);
 750       gdb_assert (SCM_UNBNDP (type_scm));
 751     }
 752
 753   *except_scmp = SCM_BOOL_F;
 754
 755   TRY_CATCH (except, RETURN_MASK_ALL)
 756     {
 757       if (vlscm_is_value (obj))
 758         {
 759           if (type != NULL)
 760             {
 761               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 762                                                    type_scm,
 763                                                    _("No type allowed"));
 764               value = NULL;
 765             }
 766           else
 767             value = value_copy (vlscm_scm_to_value (obj));
 768         }
 769       else if (gdbscm_is_true (scm_bytevector_p (obj)))
 770         {
 771           value = vlscm_convert_bytevector (obj, type, type_scm,
 772                                             obj_arg_pos, func_name,
 773                                             &except_scm, gdbarch);
 774         }
 775       else if (gdbscm_is_bool (obj))
 776         {
 777           if (type != NULL
 778               && !is_integral_type (type))
 779             {
 780               except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
 781                                                    type_scm, NULL);
 782             }
 783           else
 784             {
 785               value = value_from_longest (type
 786                                           ? type
 787                                           : language_bool_type (language,
 788                                                                 gdbarch),
 789                                           gdbscm_is_true (obj));
 790             }
 791         }
 792       else if (scm_is_number (obj))
 793         {
 794           if (type != NULL)
 795             {
 796               value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
 797                                                   type_arg_pos, type_scm, type,
 798                                                   gdbarch, &except_scm);
 799             }
 800           else
 801             {
 802               value = vlscm_convert_number (func_name, obj_arg_pos, obj,
 803                                             gdbarch, &except_scm);
 804             }
 805         }
 806       else if (scm_is_string (obj))
 807         {
 808           char *s;
 809           size_t len;
 810           struct cleanup *cleanup;
 811
 812           if (type != NULL)
 813             {
 814               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 815                                                    type_scm,
 816                                                    _("No type allowed"));
 817               value = NULL;
 818             }
 819           else
 820             {
 821               /* TODO: Provide option to specify conversion strategy.  */
 822               s = gdbscm_scm_to_string (obj, &len,
 823                                         target_charset (gdbarch),
 824                                         0 /*non-strict*/,
 825                                         &except_scm);
 826               if (s != NULL)
 827                 {
 828                   cleanup = make_cleanup (xfree, s);
 829                   value
 830                     = value_cstring (s, len,
 831                                      language_string_char_type (language,
 832                                                                 gdbarch));
 833                   do_cleanups (cleanup);
 834                 }
 835               else
 836                 value = NULL;
 837             }
 838         }
 839       else if (lsscm_is_lazy_string (obj))
 840         {
 841           if (type != NULL)
 842             {
 843               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 844                                                    type_scm,
 845                                                    _("No type allowed"));
 846               value = NULL;
 847             }
 848           else
 849             {
 850               value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
 851                                                        func_name,
 852                                                        &except_scm);
 853             }
 854         }
 855       else /* OBJ isn't anything we support.  */
 856         {
 857           except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
 858                                                NULL);
 859           value = NULL;
 860         }
 861     }
 862   if (except.reason < 0)
 863     except_scm = gdbscm_scm_from_gdb_exception (except);
 864
 865   if (gdbscm_is_true (except_scm))
 866     {
 867       gdb_assert (value == NULL);
 868       *except_scmp = except_scm;
 869     }
 870
 871   return value;
 872 }
 873
 874 /* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
 875    is no supplied type.  See vlscm_convert_typed_value_from_scheme for
 876    details.  */
 877
 878 struct value *
 879 vlscm_convert_value_from_scheme (const char *func_name,
 880                                  int obj_arg_pos, SCM obj,
 881                                  SCM *except_scmp, struct gdbarch *gdbarch,
 882                                  const struct language_defn *language)
 883 {
 884   return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
 885                                                 -1, SCM_UNDEFINED, NULL,
 886                                                 except_scmp,
 887                                                 gdbarch, language);
 888 }
 889 \f
 890 /* Initialize value math support.  */
 891
 892 static const scheme_function math_functions[] =
 893 {
 894   { "value-add", 2, 0, 0, gdbscm_value_add,
 895     "\
 896 Return a + b." },
 897
 898   { "value-sub", 2, 0, 0, gdbscm_value_sub,
 899     "\
 900 Return a - b." },
 901
 902   { "value-mul", 2, 0, 0, gdbscm_value_mul,
 903     "\
 904 Return a * b." },
 905
 906   { "value-div", 2, 0, 0, gdbscm_value_div,
 907     "\
 908 Return a / b." },
 909
 910   { "value-rem", 2, 0, 0, gdbscm_value_rem,
 911     "\
 912 Return a % b." },
 913
 914   { "value-mod", 2, 0, 0, gdbscm_value_mod,
 915     "\
 916 Return a mod b.  See Knuth 1.2.4." },
 917
 918   { "value-pow", 2, 0, 0, gdbscm_value_pow,
 919     "\
 920 Return pow (x, y)." },
 921
 922   { "value-not", 1, 0, 0, gdbscm_value_not,
 923     "\
 924 Return !a." },
 925
 926   { "value-neg", 1, 0, 0, gdbscm_value_neg,
 927     "\
 928 Return -a." },
 929
 930   { "value-pos", 1, 0, 0, gdbscm_value_pos,
 931     "\
 932 Return a." },
 933
 934   { "value-abs", 1, 0, 0, gdbscm_value_abs,
 935     "\
 936 Return abs (a)." },
 937
 938   { "value-lsh", 2, 0, 0, gdbscm_value_lsh,
 939     "\
 940 Return a << b." },
 941
 942   { "value-rsh", 2, 0, 0, gdbscm_value_rsh,
 943     "\
 944 Return a >> b." },
 945
 946   { "value-min", 2, 0, 0, gdbscm_value_min,
 947     "\
 948 Return min (a, b)." },
 949
 950   { "value-max", 2, 0, 0, gdbscm_value_max,
 951     "\
 952 Return max (a, b)." },
 953
 954   { "value-lognot", 1, 0, 0, gdbscm_value_lognot,
 955     "\
 956 Return ~a." },
 957
 958   { "value-logand", 2, 0, 0, gdbscm_value_logand,
 959     "\
 960 Return a & b." },
 961
 962   { "value-logior", 2, 0, 0, gdbscm_value_logior,
 963     "\
 964 Return a | b." },
 965
 966   { "value-logxor", 2, 0, 0, gdbscm_value_logxor,
 967     "\
 968 Return a ^ b." },
 969
 970   { "value=?", 2, 0, 0, gdbscm_value_eq_p,
 971     "\
 972 Return a == b." },
 973
 974   { "value<?", 2, 0, 0, gdbscm_value_lt_p,
 975     "\
 976 Return a < b." },
 977
 978   { "value<=?", 2, 0, 0, gdbscm_value_le_p,
 979     "\
 980 Return a <= b." },
 981
 982   { "value>?", 2, 0, 0, gdbscm_value_gt_p,
 983     "\
 984 Return a > b." },
 985
 986   { "value>=?", 2, 0, 0, gdbscm_value_ge_p,
 987     "\
 988 Return a >= b." },
 989
 990   END_FUNCTIONS
 991 };
 992
 993 void
 994 gdbscm_initialize_math (void)
 995 {
 996   gdbscm_define_functions (math_functions, 1);
 997 }