gdb/guile/scm-math.c

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