gdb/guile/scm-math.c

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