gdb/guile/scm-math.c

   1 /* GDB/Scheme support for math operations on values.
   2
   3    Copyright (C) 2008-2018 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 /* Returns a value object which is the result of applying the operation
  71    specified by OPCODE to the given argument.
  72    If there's an error a Scheme exception is thrown.  */
  73
  74 static SCM
  75 vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
  76 {
  77   struct gdbarch *gdbarch = get_current_arch ();
  78   const struct language_defn *language = current_language;
  79   struct value *arg1;
  80   SCM result = SCM_BOOL_F;
  81   struct value *res_val = NULL;
  82   SCM except_scm;
  83   struct cleanup *cleanups;
  84
  85   cleanups = make_cleanup_value_free_to_mark (value_mark ());
  86
  87   arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
  88                                           &except_scm, gdbarch, language);
  89   if (arg1 == NULL)
  90     {
  91       do_cleanups (cleanups);
  92       gdbscm_throw (except_scm);
  93     }
  94
  95   TRY
  96     {
  97       switch (opcode)
  98         {
  99         case VALSCM_NOT:
 100           /* Alas gdb and guile use the opposite meaning for "logical not".  */
 101           {
 102             struct type *type = language_bool_type (language, gdbarch);
 103             res_val
 104               = value_from_longest (type, (LONGEST) value_logical_not (arg1));
 105           }
 106           break;
 107         case VALSCM_NEG:
 108           res_val = value_neg (arg1);
 109           break;
 110         case VALSCM_NOP:
 111           /* Seemingly a no-op, but if X was a Scheme value it is now
 112              a <gdb:value> object.  */
 113           res_val = arg1;
 114           break;
 115         case VALSCM_ABS:
 116           if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
 117             res_val = value_neg (arg1);
 118           else
 119             res_val = arg1;
 120           break;
 121         case VALSCM_LOGNOT:
 122           res_val = value_complement (arg1);
 123           break;
 124         default:
 125           gdb_assert_not_reached ("unsupported operation");
 126         }
 127     }
 128   CATCH (except, RETURN_MASK_ALL)
 129     {
 130       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 131     }
 132   END_CATCH
 133
 134   gdb_assert (res_val != NULL);
 135   result = vlscm_scm_from_value (res_val);
 136
 137   do_cleanups (cleanups);
 138
 139   if (gdbscm_is_exception (result))
 140     gdbscm_throw (result);
 141
 142   return result;
 143 }
 144
 145 /* Returns a value object which is the result of applying the operation
 146    specified by OPCODE to the given arguments.
 147    If there's an error a Scheme exception is thrown.  */
 148
 149 static SCM
 150 vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
 151              const char *func_name)
 152 {
 153   struct gdbarch *gdbarch = get_current_arch ();
 154   const struct language_defn *language = current_language;
 155   struct value *arg1, *arg2;
 156   SCM result = SCM_BOOL_F;
 157   struct value *res_val = NULL;
 158   SCM except_scm;
 159   struct cleanup *cleanups;
 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
 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             ltype = check_typedef (ltype);
 188             ltype = STRIP_REFERENCE (ltype);
 189             rtype = 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             ltype = check_typedef (ltype);
 208             ltype = STRIP_REFERENCE (ltype);
 209             rtype = 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   CATCH (except, RETURN_MASK_ALL)
 268     {
 269       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 270     }
 271   END_CATCH
 272
 273   gdb_assert (res_val != NULL);
 274   result = vlscm_scm_from_value (res_val);
 275
 276   do_cleanups (cleanups);
 277
 278   if (gdbscm_is_exception (result))
 279     gdbscm_throw (result);
 280
 281   return result;
 282 }
 283
 284 /* (value-add x y) -> <gdb:value> */
 285
 286 static SCM
 287 gdbscm_value_add (SCM x, SCM y)
 288 {
 289   return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME);
 290 }
 291
 292 /* (value-sub x y) -> <gdb:value> */
 293
 294 static SCM
 295 gdbscm_value_sub (SCM x, SCM y)
 296 {
 297   return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME);
 298 }
 299
 300 /* (value-mul x y) -> <gdb:value> */
 301
 302 static SCM
 303 gdbscm_value_mul (SCM x, SCM y)
 304 {
 305   return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME);
 306 }
 307
 308 /* (value-div x y) -> <gdb:value> */
 309
 310 static SCM
 311 gdbscm_value_div (SCM x, SCM y)
 312 {
 313   return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME);
 314 }
 315
 316 /* (value-rem x y) -> <gdb:value> */
 317
 318 static SCM
 319 gdbscm_value_rem (SCM x, SCM y)
 320 {
 321   return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME);
 322 }
 323
 324 /* (value-mod x y) -> <gdb:value> */
 325
 326 static SCM
 327 gdbscm_value_mod (SCM x, SCM y)
 328 {
 329   return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME);
 330 }
 331
 332 /* (value-pow x y) -> <gdb:value> */
 333
 334 static SCM
 335 gdbscm_value_pow (SCM x, SCM y)
 336 {
 337   return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME);
 338 }
 339
 340 /* (value-neg x) -> <gdb:value> */
 341
 342 static SCM
 343 gdbscm_value_neg (SCM x)
 344 {
 345   return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
 346 }
 347
 348 /* (value-pos x) -> <gdb:value> */
 349
 350 static SCM
 351 gdbscm_value_pos (SCM x)
 352 {
 353   return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
 354 }
 355
 356 /* (value-abs x) -> <gdb:value> */
 357
 358 static SCM
 359 gdbscm_value_abs (SCM x)
 360 {
 361   return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
 362 }
 363
 364 /* (value-lsh x y) -> <gdb:value> */
 365
 366 static SCM
 367 gdbscm_value_lsh (SCM x, SCM y)
 368 {
 369   return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME);
 370 }
 371
 372 /* (value-rsh x y) -> <gdb:value> */
 373
 374 static SCM
 375 gdbscm_value_rsh (SCM x, SCM y)
 376 {
 377   return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME);
 378 }
 379
 380 /* (value-min x y) -> <gdb:value> */
 381
 382 static SCM
 383 gdbscm_value_min (SCM x, SCM y)
 384 {
 385   return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME);
 386 }
 387
 388 /* (value-max x y) -> <gdb:value> */
 389
 390 static SCM
 391 gdbscm_value_max (SCM x, SCM y)
 392 {
 393   return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME);
 394 }
 395
 396 /* (value-not x) -> <gdb:value> */
 397
 398 static SCM
 399 gdbscm_value_not (SCM x)
 400 {
 401   return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
 402 }
 403
 404 /* (value-lognot x) -> <gdb:value> */
 405
 406 static SCM
 407 gdbscm_value_lognot (SCM x)
 408 {
 409   return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
 410 }
 411
 412 /* (value-logand x y) -> <gdb:value> */
 413
 414 static SCM
 415 gdbscm_value_logand (SCM x, SCM y)
 416 {
 417   return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
 418 }
 419
 420 /* (value-logior x y) -> <gdb:value> */
 421
 422 static SCM
 423 gdbscm_value_logior (SCM x, SCM y)
 424 {
 425   return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
 426 }
 427
 428 /* (value-logxor x y) -> <gdb:value> */
 429
 430 static SCM
 431 gdbscm_value_logxor (SCM x, SCM y)
 432 {
 433   return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME);
 434 }
 435
 436 /* Utility to perform all value comparisons.
 437    If there's an error a Scheme exception is thrown.  */
 438
 439 static SCM
 440 vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
 441 {
 442   struct gdbarch *gdbarch = get_current_arch ();
 443   const struct language_defn *language = current_language;
 444   struct value *v1, *v2;
 445   int result = 0;
 446   SCM except_scm;
 447   struct cleanup *cleanups;
 448   struct gdb_exception except = exception_none;
 449
 450   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 451
 452   v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
 453                                         &except_scm, gdbarch, language);
 454   if (v1 == NULL)
 455     {
 456       do_cleanups (cleanups);
 457       gdbscm_throw (except_scm);
 458     }
 459   v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
 460                                         &except_scm, gdbarch, language);
 461   if (v2 == NULL)
 462     {
 463       do_cleanups (cleanups);
 464       gdbscm_throw (except_scm);
 465     }
 466
 467   TRY
 468     {
 469       switch (op)
 470         {
 471         case BINOP_LESS:
 472           result = value_less (v1, v2);
 473           break;
 474         case BINOP_LEQ:
 475           result = (value_less (v1, v2)
 476                     || value_equal (v1, v2));
 477           break;
 478         case BINOP_EQUAL:
 479           result = value_equal (v1, v2);
 480           break;
 481         case BINOP_NOTEQUAL:
 482           gdb_assert_not_reached ("not-equal not implemented");
 483         case BINOP_GTR:
 484           result = value_less (v2, v1);
 485           break;
 486         case BINOP_GEQ:
 487           result = (value_less (v2, v1)
 488                     || value_equal (v1, v2));
 489           break;
 490         default:
 491           gdb_assert_not_reached ("invalid <gdb:value> comparison");
 492       }
 493     }
 494   CATCH (ex, RETURN_MASK_ALL)
 495     {
 496       except = ex;
 497     }
 498   END_CATCH
 499
 500   do_cleanups (cleanups);
 501   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 502
 503   return scm_from_bool (result);
 504 }
 505
 506 /* (value=? x y) -> boolean
 507    There is no "not-equal?" function (value!= ?) on purpose.
 508    We're following string=?, etc. as our Guide here.  */
 509
 510 static SCM
 511 gdbscm_value_eq_p (SCM x, SCM y)
 512 {
 513   return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME);
 514 }
 515
 516 /* (value<? x y) -> boolean */
 517
 518 static SCM
 519 gdbscm_value_lt_p (SCM x, SCM y)
 520 {
 521   return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME);
 522 }
 523
 524 /* (value<=? x y) -> boolean */
 525
 526 static SCM
 527 gdbscm_value_le_p (SCM x, SCM y)
 528 {
 529   return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME);
 530 }
 531
 532 /* (value>? x y) -> boolean */
 533
 534 static SCM
 535 gdbscm_value_gt_p (SCM x, SCM y)
 536 {
 537   return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME);
 538 }
 539
 540 /* (value>=? x y) -> boolean */
 541
 542 static SCM
 543 gdbscm_value_ge_p (SCM x, SCM y)
 544 {
 545   return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
 546 }
 547 \f
 548 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 549    Convert OBJ, a Scheme number, to a <gdb:value> object.
 550    OBJ_ARG_POS is its position in the argument list, used in exception text.
 551
 552    TYPE is the result type.  TYPE_ARG_POS is its position in
 553    the argument list, used in exception text.
 554    TYPE_SCM is Scheme object wrapping TYPE, used in exception text.
 555
 556    If the number isn't representable, e.g. it's too big, a <gdb:exception>
 557    object is stored in *EXCEPT_SCMP and NULL is returned.
 558    The conversion may throw a gdb error, e.g., if TYPE is invalid.  */
 559
 560 static struct value *
 561 vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj,
 562                             int type_arg_pos, SCM type_scm, struct type *type,
 563                             struct gdbarch *gdbarch, SCM *except_scmp)
 564 {
 565   if (is_integral_type (type)
 566       || TYPE_CODE (type) == TYPE_CODE_PTR)
 567     {
 568       if (TYPE_UNSIGNED (type))
 569         {
 570           ULONGEST max;
 571
 572           get_unsigned_type_max (type, &max);
 573           if (!scm_is_unsigned_integer (obj, 0, max))
 574             {
 575               *except_scmp
 576                 = gdbscm_make_out_of_range_error (func_name,
 577                                                   obj_arg_pos, obj,
 578                                         _("value out of range for type"));
 579               return NULL;
 580             }
 581           return value_from_longest (type, gdbscm_scm_to_ulongest (obj));
 582         }
 583       else
 584         {
 585           LONGEST min, max;
 586
 587           get_signed_type_minmax (type, &min, &max);
 588           if (!scm_is_signed_integer (obj, min, max))
 589             {
 590               *except_scmp
 591                 = gdbscm_make_out_of_range_error (func_name,
 592                                                   obj_arg_pos, obj,
 593                                         _("value out of range for type"));
 594               return NULL;
 595             }
 596           return value_from_longest (type, gdbscm_scm_to_longest (obj));
 597         }
 598     }
 599   else if (TYPE_CODE (type) == TYPE_CODE_FLT)
 600     {
 601       struct value *value = allocate_value (type);
 602       target_float_from_host_double (value_contents_raw (value),
 603                                      value_type (value),
 604                                      scm_to_double (obj));
 605       return value;
 606     }
 607   else
 608     {
 609       *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
 610                                              NULL);
 611       return NULL;
 612     }
 613 }
 614
 615 /* Return non-zero if OBJ, an integer, fits in TYPE.  */
 616
 617 static int
 618 vlscm_integer_fits_p (SCM obj, struct type *type)
 619 {
 620   if (TYPE_UNSIGNED (type))
 621     {
 622       ULONGEST max;
 623
 624       /* If scm_is_unsigned_integer can't work with this type, just punt.  */
 625       if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax))
 626         return 0;
 627       get_unsigned_type_max (type, &max);
 628       return scm_is_unsigned_integer (obj, 0, max);
 629     }
 630   else
 631     {
 632       LONGEST min, max;
 633
 634       /* If scm_is_signed_integer can't work with this type, just punt.  */
 635       if (TYPE_LENGTH (type) > sizeof (scm_t_intmax))
 636         return 0;
 637       get_signed_type_minmax (type, &min, &max);
 638       return scm_is_signed_integer (obj, min, max);
 639     }
 640 }
 641
 642 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 643    Convert OBJ, a Scheme number, to a <gdb:value> object.
 644    OBJ_ARG_POS is its position in the argument list, used in exception text.
 645
 646    If OBJ is an integer, then the smallest int that will hold the value in
 647    the following progression is chosen:
 648    int, unsigned int, long, unsigned long, long long, unsigned long long.
 649    Otherwise, if OBJ is a real number, then it is converted to a double.
 650    Otherwise an exception is thrown.
 651
 652    If the number isn't representable, e.g. it's too big, a <gdb:exception>
 653    object is stored in *EXCEPT_SCMP and NULL is returned.  */
 654
 655 static struct value *
 656 vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
 657                       struct gdbarch *gdbarch, SCM *except_scmp)
 658 {
 659   const struct builtin_type *bt = builtin_type (gdbarch);
 660
 661   /* One thing to keep in mind here is that we are interested in the
 662      target's representation of OBJ, not the host's.  */
 663
 664   if (scm_is_exact (obj) && scm_is_integer (obj))
 665     {
 666       if (vlscm_integer_fits_p (obj, bt->builtin_int))
 667         return value_from_longest (bt->builtin_int,
 668                                    gdbscm_scm_to_longest (obj));
 669       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
 670         return value_from_longest (bt->builtin_unsigned_int,
 671                                    gdbscm_scm_to_ulongest (obj));
 672       if (vlscm_integer_fits_p (obj, bt->builtin_long))
 673         return value_from_longest (bt->builtin_long,
 674                                    gdbscm_scm_to_longest (obj));
 675       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
 676         return value_from_longest (bt->builtin_unsigned_long,
 677                                    gdbscm_scm_to_ulongest (obj));
 678       if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
 679         return value_from_longest (bt->builtin_long_long,
 680                                    gdbscm_scm_to_longest (obj));
 681       if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
 682         return value_from_longest (bt->builtin_unsigned_long_long,
 683                                    gdbscm_scm_to_ulongest (obj));
 684     }
 685   else if (scm_is_real (obj))
 686     {
 687       struct value *value = allocate_value (bt->builtin_double);
 688       target_float_from_host_double (value_contents_raw (value),
 689                                      value_type (value),
 690                                      scm_to_double (obj));
 691       return value;
 692     }
 693
 694   *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
 695                         _("value not a number representable on the target"));
 696   return NULL;
 697 }
 698
 699 /* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
 700    Convert BV, a Scheme bytevector, to a <gdb:value> object.
 701
 702    TYPE, if non-NULL, is the result type.  Otherwise, a vector of type
 703    uint8_t is used.
 704    TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
 705    or #f if TYPE is NULL.
 706
 707    If the bytevector isn't the same size as the type, then a <gdb:exception>
 708    object is stored in *EXCEPT_SCMP, and NULL is returned.  */
 709
 710 static struct value *
 711 vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
 712                           int arg_pos, const char *func_name,
 713                           SCM *except_scmp, struct gdbarch *gdbarch)
 714 {
 715   LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
 716   struct value *value;
 717
 718   if (type == NULL)
 719     {
 720       type = builtin_type (gdbarch)->builtin_uint8;
 721       type = lookup_array_range_type (type, 0, length);
 722       make_vector_type (type);
 723     }
 724   type = check_typedef (type);
 725   if (TYPE_LENGTH (type) != length)
 726     {
 727       *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
 728                                                      type_scm,
 729                         _("size of type does not match size of bytevector"));
 730       return NULL;
 731     }
 732
 733   value = value_from_contents (type,
 734                                (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
 735   return value;
 736 }
 737
 738 /* Convert OBJ, a Scheme value, to a <gdb:value> object.
 739    OBJ_ARG_POS is its position in the argument list, used in exception text.
 740
 741    TYPE, if non-NULL, is the result type which must be compatible with
 742    the value being converted.
 743    If TYPE is NULL then a suitable default type is chosen.
 744    TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
 745    or SCM_UNDEFINED if TYPE is NULL.
 746    TYPE_ARG_POS is its position in the argument list, used in exception text,
 747    or -1 if TYPE is NULL.
 748
 749    OBJ may also be a <gdb:value> object, in which case a copy is returned
 750    and TYPE must be NULL.
 751
 752    If the value cannot be converted, NULL is returned and a gdb:exception
 753    object is stored in *EXCEPT_SCMP.
 754    Otherwise the new value is returned, added to the all_values chain.  */
 755
 756 struct value *
 757 vlscm_convert_typed_value_from_scheme (const char *func_name,
 758                                        int obj_arg_pos, SCM obj,
 759                                        int type_arg_pos, SCM type_scm,
 760                                        struct type *type,
 761                                        SCM *except_scmp,
 762                                        struct gdbarch *gdbarch,
 763                                        const struct language_defn *language)
 764 {
 765   struct value *value = NULL;
 766   SCM except_scm = SCM_BOOL_F;
 767
 768   if (type == NULL)
 769     {
 770       gdb_assert (type_arg_pos == -1);
 771       gdb_assert (SCM_UNBNDP (type_scm));
 772     }
 773
 774   *except_scmp = SCM_BOOL_F;
 775
 776   TRY
 777     {
 778       if (vlscm_is_value (obj))
 779         {
 780           if (type != NULL)
 781             {
 782               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 783                                                    type_scm,
 784                                                    _("No type allowed"));
 785               value = NULL;
 786             }
 787           else
 788             value = value_copy (vlscm_scm_to_value (obj));
 789         }
 790       else if (gdbscm_is_true (scm_bytevector_p (obj)))
 791         {
 792           value = vlscm_convert_bytevector (obj, type, type_scm,
 793                                             obj_arg_pos, func_name,
 794                                             &except_scm, gdbarch);
 795         }
 796       else if (gdbscm_is_bool (obj))
 797         {
 798           if (type != NULL
 799               && !is_integral_type (type))
 800             {
 801               except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
 802                                                    type_scm, NULL);
 803             }
 804           else
 805             {
 806               value = value_from_longest (type
 807                                           ? type
 808                                           : language_bool_type (language,
 809                                                                 gdbarch),
 810                                           gdbscm_is_true (obj));
 811             }
 812         }
 813       else if (scm_is_number (obj))
 814         {
 815           if (type != NULL)
 816             {
 817               value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
 818                                                   type_arg_pos, type_scm, type,
 819                                                   gdbarch, &except_scm);
 820             }
 821           else
 822             {
 823               value = vlscm_convert_number (func_name, obj_arg_pos, obj,
 824                                             gdbarch, &except_scm);
 825             }
 826         }
 827       else if (scm_is_string (obj))
 828         {
 829           char *s;
 830           size_t len;
 831           struct cleanup *cleanup;
 832
 833           if (type != NULL)
 834             {
 835               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 836                                                    type_scm,
 837                                                    _("No type allowed"));
 838               value = NULL;
 839             }
 840           else
 841             {
 842               /* TODO: Provide option to specify conversion strategy.  */
 843               s = gdbscm_scm_to_string (obj, &len,
 844                                         target_charset (gdbarch),
 845                                         0 /*non-strict*/,
 846                                         &except_scm);
 847               if (s != NULL)
 848                 {
 849                   cleanup = make_cleanup (xfree, s);
 850                   value
 851                     = value_cstring (s, len,
 852                                      language_string_char_type (language,
 853                                                                 gdbarch));
 854                   do_cleanups (cleanup);
 855                 }
 856               else
 857                 value = NULL;
 858             }
 859         }
 860       else if (lsscm_is_lazy_string (obj))
 861         {
 862           if (type != NULL)
 863             {
 864               except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
 865                                                    type_scm,
 866                                                    _("No type allowed"));
 867               value = NULL;
 868             }
 869           else
 870             {
 871               value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
 872                                                        func_name,
 873                                                        &except_scm);
 874             }
 875         }
 876       else /* OBJ isn't anything we support.  */
 877         {
 878           except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
 879                                                NULL);
 880           value = NULL;
 881         }
 882     }
 883   CATCH (except, RETURN_MASK_ALL)
 884     {
 885       except_scm = gdbscm_scm_from_gdb_exception (except);
 886     }
 887   END_CATCH
 888
 889   if (gdbscm_is_true (except_scm))
 890     {
 891       gdb_assert (value == NULL);
 892       *except_scmp = except_scm;
 893     }
 894
 895   return value;
 896 }
 897
 898 /* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
 899    is no supplied type.  See vlscm_convert_typed_value_from_scheme for
 900    details.  */
 901
 902 struct value *
 903 vlscm_convert_value_from_scheme (const char *func_name,
 904                                  int obj_arg_pos, SCM obj,
 905                                  SCM *except_scmp, struct gdbarch *gdbarch,
 906                                  const struct language_defn *language)
 907 {
 908   return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
 909                                                 -1, SCM_UNDEFINED, NULL,
 910                                                 except_scmp,
 911                                                 gdbarch, language);
 912 }
 913 \f
 914 /* Initialize value math support.  */
 915
 916 static const scheme_function math_functions[] =
 917 {
 918   { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add),
 919     "\
 920 Return a + b." },
 921
 922   { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub),
 923     "\
 924 Return a - b." },
 925
 926   { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul),
 927     "\
 928 Return a * b." },
 929
 930   { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div),
 931     "\
 932 Return a / b." },
 933
 934   { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem),
 935     "\
 936 Return a % b." },
 937
 938   { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod),
 939     "\
 940 Return a mod b.  See Knuth 1.2.4." },
 941
 942   { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow),
 943     "\
 944 Return pow (x, y)." },
 945
 946   { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not),
 947     "\
 948 Return !a." },
 949
 950   { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg),
 951     "\
 952 Return -a." },
 953
 954   { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos),
 955     "\
 956 Return a." },
 957
 958   { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs),
 959     "\
 960 Return abs (a)." },
 961
 962   { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh),
 963     "\
 964 Return a << b." },
 965
 966   { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh),
 967     "\
 968 Return a >> b." },
 969
 970   { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min),
 971     "\
 972 Return min (a, b)." },
 973
 974   { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max),
 975     "\
 976 Return max (a, b)." },
 977
 978   { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot),
 979     "\
 980 Return ~a." },
 981
 982   { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand),
 983     "\
 984 Return a & b." },
 985
 986   { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior),
 987     "\
 988 Return a | b." },
 989
 990   { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor),
 991     "\
 992 Return a ^ b." },
 993
 994   { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p),
 995     "\
 996 Return a == b." },
 997
 998   { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p),
 999     "\
1000 Return a < b." },
1001
1002   { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p),
1003     "\
1004 Return a <= b." },
1005
1006   { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p),
1007     "\
1008 Return a > b." },
1009
1010   { "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p),
1011     "\
1012 Return a >= b." },
1013
1014   END_FUNCTIONS
1015 };
1016
1017 void
1018 gdbscm_initialize_math (void)
1019 {
1020   gdbscm_define_functions (math_functions, 1);
1021 }