gdb/guile/scm-math.c

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