gdb/guile/scm-math.c

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