gdb/guile/scm-value.c

   1 /* Scheme interface to values.
   2
   3    Copyright (C) 2008-2016 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 "infcall.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 /* The <gdb:value> smob.  */
  35
  36 typedef struct _value_smob
  37 {
  38   /* This always appears first.  */
  39   gdb_smob base;
  40
  41   /* Doubly linked list of values in values_in_scheme.
  42      IWBN to use a chained_gdb_smob instead, which is doable, it just requires
  43      a bit more casting than normal.  */
  44   struct _value_smob *next;
  45   struct _value_smob *prev;
  46
  47   struct value *value;
  48
  49   /* These are cached here to avoid making multiple copies of them.
  50      Plus computing the dynamic_type can be a bit expensive.
  51      We use #f to indicate that the value doesn't exist (e.g. value doesn't
  52      have an address), so we need another value to indicate that we haven't
  53      computed the value yet.  For this we use SCM_UNDEFINED.  */
  54   SCM address;
  55   SCM type;
  56   SCM dynamic_type;
  57 } value_smob;
  58
  59 static const char value_smob_name[] = "gdb:value";
  60
  61 /* The tag Guile knows the value smob by.  */
  62 static scm_t_bits value_smob_tag;
  63
  64 /* List of all values which are currently exposed to Scheme. It is
  65    maintained so that when an objfile is discarded, preserve_values
  66    can copy the values' types if needed.  */
  67 static value_smob *values_in_scheme;
  68
  69 /* Keywords used by Scheme procedures in this file.  */
  70 static SCM type_keyword;
  71 static SCM encoding_keyword;
  72 static SCM errors_keyword;
  73 static SCM length_keyword;
  74
  75 /* Possible #:errors values.  */
  76 static SCM error_symbol;
  77 static SCM escape_symbol;
  78 static SCM substitute_symbol;
  79 \f
  80 /* Administrivia for value smobs.  */
  81
  82 /* Iterate over all the <gdb:value> objects, calling preserve_one_value on
  83    each.
  84    This is the extension_language_ops.preserve_values "method".  */
  85
  86 void
  87 gdbscm_preserve_values (const struct extension_language_defn *extlang,
  88                         struct objfile *objfile, htab_t copied_types)
  89 {
  90   value_smob *iter;
  91
  92   for (iter = values_in_scheme; iter; iter = iter->next)
  93     preserve_one_value (iter->value, objfile, copied_types);
  94 }
  95
  96 /* Helper to add a value_smob to the global list.  */
  97
  98 static void
  99 vlscm_remember_scheme_value (value_smob *v_smob)
 100 {
 101   v_smob->next = values_in_scheme;
 102   if (v_smob->next)
 103     v_smob->next->prev = v_smob;
 104   v_smob->prev = NULL;
 105   values_in_scheme = v_smob;
 106 }
 107
 108 /* Helper to remove a value_smob from the global list.  */
 109
 110 static void
 111 vlscm_forget_value_smob (value_smob *v_smob)
 112 {
 113   /* Remove SELF from the global list.  */
 114   if (v_smob->prev)
 115     v_smob->prev->next = v_smob->next;
 116   else
 117     {
 118       gdb_assert (values_in_scheme == v_smob);
 119       values_in_scheme = v_smob->next;
 120     }
 121   if (v_smob->next)
 122     v_smob->next->prev = v_smob->prev;
 123 }
 124
 125 /* The smob "free" function for <gdb:value>.  */
 126
 127 static size_t
 128 vlscm_free_value_smob (SCM self)
 129 {
 130   value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
 131
 132   vlscm_forget_value_smob (v_smob);
 133   value_free (v_smob->value);
 134
 135   return 0;
 136 }
 137
 138 /* The smob "print" function for <gdb:value>.  */
 139
 140 static int
 141 vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
 142 {
 143   value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
 144   char *s = NULL;
 145   struct value_print_options opts;
 146
 147   if (pstate->writingp)
 148     gdbscm_printf (port, "#<%s ", value_smob_name);
 149
 150   get_user_print_options (&opts);
 151   opts.deref_ref = 0;
 152
 153   /* pstate->writingp = zero if invoked by display/~A, and nonzero if
 154      invoked by write/~S.  What to do here may need to evolve.
 155      IWBN if we could pass an argument to format that would we could use
 156      instead of writingp.  */
 157   opts.raw = !!pstate->writingp;
 158
 159   TRY
 160     {
 161       struct ui_file *stb = mem_fileopen ();
 162       struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
 163
 164       common_val_print (v_smob->value, stb, 0, &opts, current_language);
 165       s = ui_file_xstrdup (stb, NULL);
 166
 167       do_cleanups (old_chain);
 168     }
 169   CATCH (except, RETURN_MASK_ALL)
 170     {
 171       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 172     }
 173   END_CATCH
 174
 175   if (s != NULL)
 176     {
 177       scm_puts (s, port);
 178       xfree (s);
 179     }
 180
 181   if (pstate->writingp)
 182     scm_puts (">", port);
 183
 184   scm_remember_upto_here_1 (self);
 185
 186   /* Non-zero means success.  */
 187   return 1;
 188 }
 189
 190 /* The smob "equalp" function for <gdb:value>.  */
 191
 192 static SCM
 193 vlscm_equal_p_value_smob (SCM v1, SCM v2)
 194 {
 195   const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
 196   const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
 197   int result = 0;
 198
 199   TRY
 200     {
 201       result = value_equal (v1_smob->value, v2_smob->value);
 202     }
 203   CATCH (except, RETURN_MASK_ALL)
 204     {
 205       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 206     }
 207   END_CATCH
 208
 209   return scm_from_bool (result);
 210 }
 211
 212 /* Low level routine to create a <gdb:value> object.  */
 213
 214 static SCM
 215 vlscm_make_value_smob (void)
 216 {
 217   value_smob *v_smob = (value_smob *)
 218     scm_gc_malloc (sizeof (value_smob), value_smob_name);
 219   SCM v_scm;
 220
 221   /* These must be filled in by the caller.  */
 222   v_smob->value = NULL;
 223   v_smob->prev = NULL;
 224   v_smob->next = NULL;
 225
 226   /* These are lazily computed.  */
 227   v_smob->address = SCM_UNDEFINED;
 228   v_smob->type = SCM_UNDEFINED;
 229   v_smob->dynamic_type = SCM_UNDEFINED;
 230
 231   v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
 232   gdbscm_init_gsmob (&v_smob->base);
 233
 234   return v_scm;
 235 }
 236
 237 /* Return non-zero if SCM is a <gdb:value> object.  */
 238
 239 int
 240 vlscm_is_value (SCM scm)
 241 {
 242   return SCM_SMOB_PREDICATE (value_smob_tag, scm);
 243 }
 244
 245 /* (value? object) -> boolean */
 246
 247 static SCM
 248 gdbscm_value_p (SCM scm)
 249 {
 250   return scm_from_bool (vlscm_is_value (scm));
 251 }
 252
 253 /* Create a new <gdb:value> object that encapsulates VALUE.
 254    The value is released from the all_values chain so its lifetime is not
 255    bound to the execution of a command.  */
 256
 257 SCM
 258 vlscm_scm_from_value (struct value *value)
 259 {
 260   /* N.B. It's important to not cause any side-effects until we know the
 261      conversion worked.  */
 262   SCM v_scm = vlscm_make_value_smob ();
 263   value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
 264
 265   v_smob->value = value;
 266   release_value_or_incref (value);
 267   vlscm_remember_scheme_value (v_smob);
 268
 269   return v_scm;
 270 }
 271
 272 /* Returns the <gdb:value> object in SELF.
 273    Throws an exception if SELF is not a <gdb:value> object.  */
 274
 275 static SCM
 276 vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 277 {
 278   SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
 279                    value_smob_name);
 280
 281   return self;
 282 }
 283
 284 /* Returns a pointer to the value smob of SELF.
 285    Throws an exception if SELF is not a <gdb:value> object.  */
 286
 287 static value_smob *
 288 vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 289 {
 290   SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
 291   value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
 292
 293   return v_smob;
 294 }
 295
 296 /* Return the value field of V_SCM, an object of type <gdb:value>.
 297    This exists so that we don't have to export the struct's contents.  */
 298
 299 struct value *
 300 vlscm_scm_to_value (SCM v_scm)
 301 {
 302   value_smob *v_smob;
 303
 304   gdb_assert (vlscm_is_value (v_scm));
 305   v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
 306   return v_smob->value;
 307 }
 308 \f
 309 /* Value methods.  */
 310
 311 /* (make-value x [#:type type]) -> <gdb:value> */
 312
 313 static SCM
 314 gdbscm_make_value (SCM x, SCM rest)
 315 {
 316   struct gdbarch *gdbarch = get_current_arch ();
 317   const struct language_defn *language = current_language;
 318   const SCM keywords[] = { type_keyword, SCM_BOOL_F };
 319   int type_arg_pos = -1;
 320   SCM type_scm = SCM_UNDEFINED;
 321   SCM except_scm, result;
 322   type_smob *t_smob;
 323   struct type *type = NULL;
 324   struct value *value;
 325   struct cleanup *cleanups;
 326
 327   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
 328                               &type_arg_pos, &type_scm);
 329
 330   if (type_arg_pos > 0)
 331     {
 332       t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
 333                                                FUNC_NAME);
 334       type = tyscm_type_smob_type (t_smob);
 335     }
 336
 337   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 338
 339   value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
 340                                                  type_arg_pos, type_scm, type,
 341                                                  &except_scm,
 342                                                  gdbarch, language);
 343   if (value == NULL)
 344     {
 345       do_cleanups (cleanups);
 346       gdbscm_throw (except_scm);
 347     }
 348
 349   result = vlscm_scm_from_value (value);
 350
 351   do_cleanups (cleanups);
 352
 353   if (gdbscm_is_exception (result))
 354     gdbscm_throw (result);
 355   return result;
 356 }
 357
 358 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
 359
 360 static SCM
 361 gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
 362 {
 363   type_smob *t_smob;
 364   struct type *type;
 365   ULONGEST address;
 366   struct value *value = NULL;
 367   SCM result;
 368   struct cleanup *cleanups;
 369
 370   t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
 371   type = tyscm_type_smob_type (t_smob);
 372
 373   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
 374                               address_scm, &address);
 375
 376   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 377
 378   /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
 379      and future-proofing we do.  */
 380   TRY
 381   {
 382     value = value_from_contents_and_address (type, NULL, address);
 383   }
 384   CATCH (except, RETURN_MASK_ALL)
 385     {
 386       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 387     }
 388   END_CATCH
 389
 390   result = vlscm_scm_from_value (value);
 391
 392   do_cleanups (cleanups);
 393
 394   if (gdbscm_is_exception (result))
 395     gdbscm_throw (result);
 396   return result;
 397 }
 398
 399 /* (value-optimized-out? <gdb:value>) -> boolean */
 400
 401 static SCM
 402 gdbscm_value_optimized_out_p (SCM self)
 403 {
 404   value_smob *v_smob
 405     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 406   struct value *value = v_smob->value;
 407   int opt = 0;
 408
 409   TRY
 410     {
 411       opt = value_optimized_out (value);
 412     }
 413   CATCH (except, RETURN_MASK_ALL)
 414     {
 415       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 416     }
 417   END_CATCH
 418
 419   return scm_from_bool (opt);
 420 }
 421
 422 /* (value-address <gdb:value>) -> integer
 423    Returns #f if the value doesn't have one.  */
 424
 425 static SCM
 426 gdbscm_value_address (SCM self)
 427 {
 428   value_smob *v_smob
 429     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 430   struct value *value = v_smob->value;
 431
 432   if (SCM_UNBNDP (v_smob->address))
 433     {
 434       struct value *res_val = NULL;
 435       struct cleanup *cleanup
 436         = make_cleanup_value_free_to_mark (value_mark ());
 437       SCM address;
 438
 439       TRY
 440         {
 441           res_val = value_addr (value);
 442         }
 443       CATCH (except, RETURN_MASK_ALL)
 444         {
 445           address = SCM_BOOL_F;
 446         }
 447       END_CATCH
 448
 449       if (res_val != NULL)
 450         address = vlscm_scm_from_value (res_val);
 451
 452       do_cleanups (cleanup);
 453
 454       if (gdbscm_is_exception (address))
 455         gdbscm_throw (address);
 456
 457       v_smob->address = address;
 458     }
 459
 460   return v_smob->address;
 461 }
 462
 463 /* (value-dereference <gdb:value>) -> <gdb:value>
 464    Given a value of a pointer type, apply the C unary * operator to it.  */
 465
 466 static SCM
 467 gdbscm_value_dereference (SCM self)
 468 {
 469   value_smob *v_smob
 470     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 471   struct value *value = v_smob->value;
 472   SCM result;
 473   struct value *res_val = NULL;
 474   struct cleanup *cleanups;
 475
 476   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 477
 478   TRY
 479     {
 480       res_val = value_ind (value);
 481     }
 482   CATCH (except, RETURN_MASK_ALL)
 483     {
 484       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 485     }
 486   END_CATCH
 487
 488   result = vlscm_scm_from_value (res_val);
 489
 490   do_cleanups (cleanups);
 491
 492   if (gdbscm_is_exception (result))
 493     gdbscm_throw (result);
 494
 495   return result;
 496 }
 497
 498 /* (value-referenced-value <gdb:value>) -> <gdb:value>
 499    Given a value of a reference type, return the value referenced.
 500    The difference between this function and gdbscm_value_dereference is that
 501    the latter applies * unary operator to a value, which need not always
 502    result in the value referenced.
 503    For example, for a value which is a reference to an 'int' pointer ('int *'),
 504    gdbscm_value_dereference will result in a value of type 'int' while
 505    gdbscm_value_referenced_value will result in a value of type 'int *'.  */
 506
 507 static SCM
 508 gdbscm_value_referenced_value (SCM self)
 509 {
 510   value_smob *v_smob
 511     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 512   struct value *value = v_smob->value;
 513   SCM result;
 514   struct value *res_val = NULL;
 515   struct cleanup *cleanups;
 516
 517   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 518
 519   TRY
 520     {
 521       switch (TYPE_CODE (check_typedef (value_type (value))))
 522         {
 523         case TYPE_CODE_PTR:
 524           res_val = value_ind (value);
 525           break;
 526         case TYPE_CODE_REF:
 527           res_val = coerce_ref (value);
 528           break;
 529         default:
 530           error (_("Trying to get the referenced value from a value which is"
 531                    " neither a pointer nor a reference"));
 532         }
 533     }
 534   CATCH (except, RETURN_MASK_ALL)
 535     {
 536       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 537     }
 538   END_CATCH
 539
 540   result = vlscm_scm_from_value (res_val);
 541
 542   do_cleanups (cleanups);
 543
 544   if (gdbscm_is_exception (result))
 545     gdbscm_throw (result);
 546
 547   return result;
 548 }
 549
 550 /* (value-type <gdb:value>) -> <gdb:type> */
 551
 552 static SCM
 553 gdbscm_value_type (SCM self)
 554 {
 555   value_smob *v_smob
 556     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 557   struct value *value = v_smob->value;
 558
 559   if (SCM_UNBNDP (v_smob->type))
 560     v_smob->type = tyscm_scm_from_type (value_type (value));
 561
 562   return v_smob->type;
 563 }
 564
 565 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
 566
 567 static SCM
 568 gdbscm_value_dynamic_type (SCM self)
 569 {
 570   value_smob *v_smob
 571     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 572   struct value *value = v_smob->value;
 573   struct type *type = NULL;
 574
 575   if (! SCM_UNBNDP (v_smob->dynamic_type))
 576     return v_smob->dynamic_type;
 577
 578   TRY
 579     {
 580       struct cleanup *cleanup
 581         = make_cleanup_value_free_to_mark (value_mark ());
 582
 583       type = value_type (value);
 584       type = check_typedef (type);
 585
 586       if (((TYPE_CODE (type) == TYPE_CODE_PTR)
 587            || (TYPE_CODE (type) == TYPE_CODE_REF))
 588           && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRUCT))
 589         {
 590           struct value *target;
 591           int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
 592
 593           if (was_pointer)
 594             target = value_ind (value);
 595           else
 596             target = coerce_ref (value);
 597           type = value_rtti_type (target, NULL, NULL, NULL);
 598
 599           if (type)
 600             {
 601               if (was_pointer)
 602                 type = lookup_pointer_type (type);
 603               else
 604                 type = lookup_reference_type (type);
 605             }
 606         }
 607       else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
 608         type = value_rtti_type (value, NULL, NULL, NULL);
 609       else
 610         {
 611           /* Re-use object's static type.  */
 612           type = NULL;
 613         }
 614
 615       do_cleanups (cleanup);
 616     }
 617   CATCH (except, RETURN_MASK_ALL)
 618     {
 619       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 620     }
 621   END_CATCH
 622
 623   if (type == NULL)
 624     v_smob->dynamic_type = gdbscm_value_type (self);
 625   else
 626     v_smob->dynamic_type = tyscm_scm_from_type (type);
 627
 628   return v_smob->dynamic_type;
 629 }
 630
 631 /* A helper function that implements the various cast operators.  */
 632
 633 static SCM
 634 vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
 635                const char *func_name)
 636 {
 637   value_smob *v_smob
 638     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 639   struct value *value = v_smob->value;
 640   type_smob *t_smob
 641     = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
 642   struct type *type = tyscm_type_smob_type (t_smob);
 643   SCM result;
 644   struct value *res_val = NULL;
 645   struct cleanup *cleanups;
 646
 647   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 648
 649   TRY
 650     {
 651       if (op == UNOP_DYNAMIC_CAST)
 652         res_val = value_dynamic_cast (type, value);
 653       else if (op == UNOP_REINTERPRET_CAST)
 654         res_val = value_reinterpret_cast (type, value);
 655       else
 656         {
 657           gdb_assert (op == UNOP_CAST);
 658           res_val = value_cast (type, value);
 659         }
 660     }
 661   CATCH (except, RETURN_MASK_ALL)
 662     {
 663       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 664     }
 665   END_CATCH
 666
 667   gdb_assert (res_val != NULL);
 668   result = vlscm_scm_from_value (res_val);
 669
 670   do_cleanups (cleanups);
 671
 672   if (gdbscm_is_exception (result))
 673     gdbscm_throw (result);
 674
 675   return result;
 676 }
 677
 678 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
 679
 680 static SCM
 681 gdbscm_value_cast (SCM self, SCM new_type)
 682 {
 683   return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
 684 }
 685
 686 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
 687
 688 static SCM
 689 gdbscm_value_dynamic_cast (SCM self, SCM new_type)
 690 {
 691   return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
 692 }
 693
 694 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
 695
 696 static SCM
 697 gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
 698 {
 699   return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
 700 }
 701
 702 /* (value-field <gdb:value> string) -> <gdb:value>
 703    Given string name of an element inside structure, return its <gdb:value>
 704    object.  */
 705
 706 static SCM
 707 gdbscm_value_field (SCM self, SCM field_scm)
 708 {
 709   value_smob *v_smob
 710     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 711   struct value *value = v_smob->value;
 712   char *field = NULL;
 713   struct value *res_val = NULL;
 714   SCM result;
 715   struct cleanup *cleanups;
 716
 717   SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
 718                    _("string"));
 719
 720   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 721
 722   field = gdbscm_scm_to_c_string (field_scm);
 723   make_cleanup (xfree, field);
 724
 725   TRY
 726     {
 727       struct value *tmp = value;
 728
 729       res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
 730     }
 731   CATCH (except, RETURN_MASK_ALL)
 732     {
 733       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 734     }
 735   END_CATCH
 736
 737   gdb_assert (res_val != NULL);
 738   result = vlscm_scm_from_value (res_val);
 739
 740   do_cleanups (cleanups);
 741
 742   if (gdbscm_is_exception (result))
 743     gdbscm_throw (result);
 744
 745   return result;
 746 }
 747
 748 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
 749    Return the specified value in an array.  */
 750
 751 static SCM
 752 gdbscm_value_subscript (SCM self, SCM index_scm)
 753 {
 754   value_smob *v_smob
 755     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 756   struct value *value = v_smob->value;
 757   struct value *index = NULL;
 758   struct value *res_val = NULL;
 759   struct type *type = value_type (value);
 760   struct gdbarch *gdbarch;
 761   SCM result, except_scm;
 762   struct cleanup *cleanups;
 763
 764   /* The sequencing here, as everywhere else, is important.
 765      We can't have existing cleanups when a Scheme exception is thrown.  */
 766
 767   SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
 768   gdbarch = get_type_arch (type);
 769
 770   cleanups = make_cleanup_value_free_to_mark (value_mark ());
 771
 772   index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
 773                                            &except_scm,
 774                                            gdbarch, current_language);
 775   if (index == NULL)
 776     {
 777       do_cleanups (cleanups);
 778       gdbscm_throw (except_scm);
 779     }
 780
 781   TRY
 782     {
 783       struct value *tmp = value;
 784
 785       /* Assume we are attempting an array access, and let the value code
 786          throw an exception if the index has an invalid type.
 787          Check the value's type is something that can be accessed via
 788          a subscript.  */
 789       tmp = coerce_ref (tmp);
 790       type = check_typedef (value_type (tmp));
 791       if (TYPE_CODE (type) != TYPE_CODE_ARRAY
 792           && TYPE_CODE (type) != TYPE_CODE_PTR)
 793         error (_("Cannot subscript requested type"));
 794
 795       res_val = value_subscript (tmp, value_as_long (index));
 796    }
 797   CATCH (except, RETURN_MASK_ALL)
 798     {
 799       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 800     }
 801   END_CATCH
 802
 803   gdb_assert (res_val != NULL);
 804   result = vlscm_scm_from_value (res_val);
 805
 806   do_cleanups (cleanups);
 807
 808   if (gdbscm_is_exception (result))
 809     gdbscm_throw (result);
 810
 811   return result;
 812 }
 813
 814 /* (value-call <gdb:value> arg-list) -> <gdb:value>
 815    Perform an inferior function call on the value.  */
 816
 817 static SCM
 818 gdbscm_value_call (SCM self, SCM args)
 819 {
 820   value_smob *v_smob
 821     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 822   struct value *function = v_smob->value;
 823   struct value *mark = value_mark ();
 824   struct type *ftype = NULL;
 825   long args_count;
 826   struct value **vargs = NULL;
 827   SCM result = SCM_BOOL_F;
 828
 829   TRY
 830     {
 831       ftype = check_typedef (value_type (function));
 832     }
 833   CATCH (except, RETURN_MASK_ALL)
 834     {
 835       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 836     }
 837   END_CATCH
 838
 839   SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
 840                    SCM_ARG1, FUNC_NAME,
 841                    _("function (value of TYPE_CODE_FUNC)"));
 842
 843   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
 844                    SCM_ARG2, FUNC_NAME, _("list"));
 845
 846   args_count = scm_ilength (args);
 847   if (args_count > 0)
 848     {
 849       struct gdbarch *gdbarch = get_current_arch ();
 850       const struct language_defn *language = current_language;
 851       SCM except_scm;
 852       long i;
 853
 854       vargs = XALLOCAVEC (struct value *, args_count);
 855       for (i = 0; i < args_count; i++)
 856         {
 857           SCM arg = scm_car (args);
 858
 859           vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
 860                                                       GDBSCM_ARG_NONE, arg,
 861                                                       &except_scm,
 862                                                       gdbarch, language);
 863           if (vargs[i] == NULL)
 864             gdbscm_throw (except_scm);
 865
 866           args = scm_cdr (args);
 867         }
 868       gdb_assert (gdbscm_is_true (scm_null_p (args)));
 869     }
 870
 871   TRY
 872     {
 873       struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
 874       struct value *return_value;
 875
 876       return_value = call_function_by_hand (function, args_count, vargs);
 877       result = vlscm_scm_from_value (return_value);
 878       do_cleanups (cleanup);
 879     }
 880   CATCH (except, RETURN_MASK_ALL)
 881     {
 882       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 883     }
 884   END_CATCH
 885
 886   if (gdbscm_is_exception (result))
 887     gdbscm_throw (result);
 888
 889   return result;
 890 }
 891
 892 /* (value->bytevector <gdb:value>) -> bytevector */
 893
 894 static SCM
 895 gdbscm_value_to_bytevector (SCM self)
 896 {
 897   value_smob *v_smob
 898     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 899   struct value *value = v_smob->value;
 900   struct type *type;
 901   size_t length = 0;
 902   const gdb_byte *contents = NULL;
 903   SCM bv;
 904
 905   type = value_type (value);
 906
 907   TRY
 908     {
 909       type = check_typedef (type);
 910       length = TYPE_LENGTH (type);
 911       contents = value_contents (value);
 912     }
 913   CATCH (except, RETURN_MASK_ALL)
 914     {
 915       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 916     }
 917   END_CATCH
 918
 919   bv = scm_c_make_bytevector (length);
 920   memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
 921
 922   return bv;
 923 }
 924
 925 /* Helper function to determine if a type is "int-like".  */
 926
 927 static int
 928 is_intlike (struct type *type, int ptr_ok)
 929 {
 930   return (TYPE_CODE (type) == TYPE_CODE_INT
 931           || TYPE_CODE (type) == TYPE_CODE_ENUM
 932           || TYPE_CODE (type) == TYPE_CODE_BOOL
 933           || TYPE_CODE (type) == TYPE_CODE_CHAR
 934           || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
 935 }
 936
 937 /* (value->bool <gdb:value>) -> boolean
 938    Throws an error if the value is not integer-like.  */
 939
 940 static SCM
 941 gdbscm_value_to_bool (SCM self)
 942 {
 943   value_smob *v_smob
 944     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 945   struct value *value = v_smob->value;
 946   struct type *type;
 947   LONGEST l = 0;
 948
 949   type = value_type (value);
 950
 951   TRY
 952     {
 953       type = check_typedef (type);
 954     }
 955   CATCH (except, RETURN_MASK_ALL)
 956     {
 957       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 958     }
 959   END_CATCH
 960
 961   SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
 962                    _("integer-like gdb value"));
 963
 964   TRY
 965     {
 966       if (TYPE_CODE (type) == TYPE_CODE_PTR)
 967         l = value_as_address (value);
 968       else
 969         l = value_as_long (value);
 970     }
 971   CATCH (except, RETURN_MASK_ALL)
 972     {
 973       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 974     }
 975   END_CATCH
 976
 977   return scm_from_bool (l != 0);
 978 }
 979
 980 /* (value->integer <gdb:value>) -> integer
 981    Throws an error if the value is not integer-like.  */
 982
 983 static SCM
 984 gdbscm_value_to_integer (SCM self)
 985 {
 986   value_smob *v_smob
 987     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 988   struct value *value = v_smob->value;
 989   struct type *type;
 990   LONGEST l = 0;
 991
 992   type = value_type (value);
 993
 994   TRY
 995     {
 996       type = check_typedef (type);
 997     }
 998   CATCH (except, RETURN_MASK_ALL)
 999     {
1000       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1001     }
1002   END_CATCH
1003
1004   SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
1005                    _("integer-like gdb value"));
1006
1007   TRY
1008     {
1009       if (TYPE_CODE (type) == TYPE_CODE_PTR)
1010         l = value_as_address (value);
1011       else
1012         l = value_as_long (value);
1013     }
1014   CATCH (except, RETURN_MASK_ALL)
1015     {
1016       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1017     }
1018   END_CATCH
1019
1020   if (TYPE_UNSIGNED (type))
1021     return gdbscm_scm_from_ulongest (l);
1022   else
1023     return gdbscm_scm_from_longest (l);
1024 }
1025
1026 /* (value->real <gdb:value>) -> real
1027    Throws an error if the value is not a number.  */
1028
1029 static SCM
1030 gdbscm_value_to_real (SCM self)
1031 {
1032   value_smob *v_smob
1033     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1034   struct value *value = v_smob->value;
1035   struct type *type;
1036   DOUBLEST d = 0;
1037
1038   type = value_type (value);
1039
1040   TRY
1041     {
1042       type = check_typedef (type);
1043     }
1044   CATCH (except, RETURN_MASK_ALL)
1045     {
1046       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1047     }
1048   END_CATCH
1049
1050   SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
1051                    self, SCM_ARG1, FUNC_NAME, _("number"));
1052
1053   TRY
1054     {
1055       d = value_as_double (value);
1056     }
1057   CATCH (except, RETURN_MASK_ALL)
1058     {
1059       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1060     }
1061   END_CATCH
1062
1063   /* TODO: Is there a better way to check if the value fits?  */
1064   if (d != (double) d)
1065     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1066                                _("number can't be converted to a double"));
1067
1068   return scm_from_double (d);
1069 }
1070
1071 /* (value->string <gdb:value>
1072        [#:encoding encoding]
1073        [#:errors #f | 'error | 'substitute]
1074        [#:length length])
1075      -> string
1076    Return Unicode string with value's contents, which must be a string.
1077
1078    If ENCODING is not given, the string is assumed to be encoded in
1079    the target's charset.
1080
1081    ERRORS is one of #f, 'error or 'substitute.
1082    An error setting of #f means use the default, which is Guile's
1083    %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1084    using an earlier version of Guile.  Earlier versions do not properly
1085    support obtaining the default port conversion strategy.
1086    If the default is not one of 'error or 'substitute, 'substitute is used.
1087    An error setting of "error" causes an exception to be thrown if there's
1088    a decoding error.  An error setting of "substitute" causes invalid
1089    characters to be replaced with "?".
1090
1091    If LENGTH is provided, only fetch string to the length provided.
1092    LENGTH must be a Scheme integer, it can't be a <gdb:value> integer.  */
1093
1094 static SCM
1095 gdbscm_value_to_string (SCM self, SCM rest)
1096 {
1097   value_smob *v_smob
1098     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1099   struct value *value = v_smob->value;
1100   const SCM keywords[] = {
1101     encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
1102   };
1103   int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
1104   char *encoding = NULL;
1105   SCM errors = SCM_BOOL_F;
1106   int length = -1;
1107   gdb_byte *buffer = NULL;
1108   const char *la_encoding = NULL;
1109   struct type *char_type = NULL;
1110   SCM result;
1111   struct cleanup *cleanups;
1112
1113   /* The sequencing here, as everywhere else, is important.
1114      We can't have existing cleanups when a Scheme exception is thrown.  */
1115
1116   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
1117                               &encoding_arg_pos, &encoding,
1118                               &errors_arg_pos, &errors,
1119                               &length_arg_pos, &length);
1120
1121   cleanups = make_cleanup (xfree, encoding);
1122
1123   if (errors_arg_pos > 0
1124       && errors != SCM_BOOL_F
1125       && !scm_is_eq (errors, error_symbol)
1126       && !scm_is_eq (errors, substitute_symbol))
1127     {
1128       SCM excp
1129         = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
1130                                           _("invalid error kind"));
1131
1132       do_cleanups (cleanups);
1133       gdbscm_throw (excp);
1134     }
1135   if (errors == SCM_BOOL_F)
1136     {
1137       /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1138          will throw a Scheme error when passed #f.  */
1139       if (gdbscm_guile_version_is_at_least (2, 0, 6))
1140         errors = scm_port_conversion_strategy (SCM_BOOL_F);
1141       else
1142         errors = error_symbol;
1143     }
1144   /* We don't assume anything about the result of scm_port_conversion_strategy.
1145      From this point on, if errors is not 'errors, use 'substitute.  */
1146
1147   TRY
1148     {
1149       LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
1150     }
1151   CATCH (except, RETURN_MASK_ALL)
1152     {
1153       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1154     }
1155   END_CATCH
1156
1157   /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1158      Make sure we don't leak.  This is done via scm_dynwind_begin, et.al.  */
1159   discard_cleanups (cleanups);
1160
1161   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
1162
1163   gdbscm_dynwind_xfree (encoding);
1164   gdbscm_dynwind_xfree (buffer);
1165
1166   result = scm_from_stringn ((const char *) buffer,
1167                              length * TYPE_LENGTH (char_type),
1168                              (encoding != NULL && *encoding != '\0'
1169                               ? encoding
1170                               : la_encoding),
1171                              scm_is_eq (errors, error_symbol)
1172                              ? SCM_FAILED_CONVERSION_ERROR
1173                              : SCM_FAILED_CONVERSION_QUESTION_MARK);
1174
1175   scm_dynwind_end ();
1176
1177   return result;
1178 }
1179
1180 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1181      -> <gdb:lazy-string>
1182    Return a Scheme object representing a lazy_string_object type.
1183    A lazy string is a pointer to a string with an optional encoding and length.
1184    If ENCODING is not given, the target's charset is used.
1185    If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1186    length will be set to -1 (first null of appropriate with).
1187    LENGTH must be a Scheme integer, it can't be a <gdb:value> integer.  */
1188
1189 static SCM
1190 gdbscm_value_to_lazy_string (SCM self, SCM rest)
1191 {
1192   value_smob *v_smob
1193     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1194   struct value *value = v_smob->value;
1195   const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
1196   int encoding_arg_pos = -1, length_arg_pos = -1;
1197   char *encoding = NULL;
1198   int length = -1;
1199   SCM result = SCM_BOOL_F; /* -Wall */
1200   struct cleanup *cleanups;
1201   struct gdb_exception except = exception_none;
1202
1203   /* The sequencing here, as everywhere else, is important.
1204      We can't have existing cleanups when a Scheme exception is thrown.  */
1205
1206   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
1207                               &encoding_arg_pos, &encoding,
1208                               &length_arg_pos, &length);
1209
1210   cleanups = make_cleanup (xfree, encoding);
1211
1212   TRY
1213     {
1214       struct cleanup *inner_cleanup
1215         = make_cleanup_value_free_to_mark (value_mark ());
1216
1217       if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
1218         value = value_ind (value);
1219
1220       result = lsscm_make_lazy_string (value_address (value), length,
1221                                        encoding, value_type (value));
1222
1223       do_cleanups (inner_cleanup);
1224     }
1225   CATCH (ex, RETURN_MASK_ALL)
1226     {
1227       except = ex;
1228     }
1229   END_CATCH
1230
1231   do_cleanups (cleanups);
1232   GDBSCM_HANDLE_GDB_EXCEPTION (except);
1233
1234   if (gdbscm_is_exception (result))
1235     gdbscm_throw (result);
1236
1237   return result;
1238 }
1239
1240 /* (value-lazy? <gdb:value>) -> boolean */
1241
1242 static SCM
1243 gdbscm_value_lazy_p (SCM self)
1244 {
1245   value_smob *v_smob
1246     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1247   struct value *value = v_smob->value;
1248
1249   return scm_from_bool (value_lazy (value));
1250 }
1251
1252 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1253
1254 static SCM
1255 gdbscm_value_fetch_lazy_x (SCM self)
1256 {
1257   value_smob *v_smob
1258     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1259   struct value *value = v_smob->value;
1260
1261   TRY
1262     {
1263       if (value_lazy (value))
1264         value_fetch_lazy (value);
1265     }
1266   CATCH (except, RETURN_MASK_ALL)
1267     {
1268       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1269     }
1270   END_CATCH
1271
1272   return SCM_UNSPECIFIED;
1273 }
1274
1275 /* (value-print <gdb:value>) -> string */
1276
1277 static SCM
1278 gdbscm_value_print (SCM self)
1279 {
1280   value_smob *v_smob
1281     = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1282   struct value *value = v_smob->value;
1283   struct value_print_options opts;
1284   char *s = NULL;
1285   SCM result;
1286
1287   get_user_print_options (&opts);
1288   opts.deref_ref = 0;
1289
1290   TRY
1291     {
1292       struct ui_file *stb = mem_fileopen ();
1293       struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
1294
1295       common_val_print (value, stb, 0, &opts, current_language);
1296       s = ui_file_xstrdup (stb, NULL);
1297
1298       do_cleanups (old_chain);
1299     }
1300   CATCH (except, RETURN_MASK_ALL)
1301     {
1302       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1303     }
1304   END_CATCH
1305
1306   /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1307      throw an error if the encoding fails.
1308      IWBN to use scm_take_locale_string here, but we'd have to temporarily
1309      override the default port conversion handler because contrary to
1310      documentation it doesn't necessarily free the input string.  */
1311   result = scm_from_stringn (s, strlen (s), host_charset (),
1312                              SCM_FAILED_CONVERSION_QUESTION_MARK);
1313   xfree (s);
1314
1315   return result;
1316 }
1317 \f
1318 /* (parse-and-eval string) -> <gdb:value>
1319    Parse a string and evaluate the string as an expression.  */
1320
1321 static SCM
1322 gdbscm_parse_and_eval (SCM expr_scm)
1323 {
1324   char *expr_str;
1325   struct value *res_val = NULL;
1326   SCM result;
1327   struct cleanup *cleanups;
1328
1329   /* The sequencing here, as everywhere else, is important.
1330      We can't have existing cleanups when a Scheme exception is thrown.  */
1331
1332   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
1333                               expr_scm, &expr_str);
1334
1335   cleanups = make_cleanup_value_free_to_mark (value_mark ());
1336   make_cleanup (xfree, expr_str);
1337
1338   TRY
1339     {
1340       res_val = parse_and_eval (expr_str);
1341     }
1342   CATCH (except, RETURN_MASK_ALL)
1343     {
1344       GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1345     }
1346   END_CATCH
1347
1348   gdb_assert (res_val != NULL);
1349   result = vlscm_scm_from_value (res_val);
1350
1351   do_cleanups (cleanups);
1352
1353   if (gdbscm_is_exception (result))
1354     gdbscm_throw (result);
1355
1356   return result;
1357 }
1358
1359 /* (history-ref integer) -> <gdb:value>
1360    Return the specified value from GDB's value history.  */
1361
1362 static SCM
1363 gdbscm_history_ref (SCM index)
1364 {
1365   int i;
1366   struct value *res_val = NULL; /* Initialize to appease gcc warning.  */
1367
1368   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
1369
1370   TRY
1371     {
1372       res_val = access_value_history (i);
1373     }
1374   CATCH (except, RETURN_MASK_ALL)
1375     {
1376       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1377     }
1378   END_CATCH
1379
1380   return vlscm_scm_from_value (res_val);
1381 }
1382
1383 /* (history-append! <gdb:value>) -> index
1384    Append VALUE to GDB's value history.  Return its index in the history.  */
1385
1386 static SCM
1387 gdbscm_history_append_x (SCM value)
1388 {
1389   int res_index = -1;
1390   struct value *v;
1391   value_smob *v_smob;
1392
1393   v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
1394   v = v_smob->value;
1395
1396   TRY
1397     {
1398       res_index = record_latest_value (v);
1399     }
1400   CATCH (except, RETURN_MASK_ALL)
1401     {
1402       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1403     }
1404   END_CATCH
1405
1406   return scm_from_int (res_index);
1407 }
1408 \f
1409 /* Initialize the Scheme value code.  */
1410
1411 static const scheme_function value_functions[] =
1412 {
1413   { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p),
1414     "\
1415 Return #t if the object is a <gdb:value> object." },
1416
1417   { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value),
1418     "\
1419 Create a <gdb:value> representing object.\n\
1420 Typically this is used to convert numbers and strings to\n\
1421 <gdb:value> objects.\n\
1422 \n\
1423   Arguments: object [#:type <gdb:type>]" },
1424
1425   { "value-optimized-out?", 1, 0, 0,
1426     as_a_scm_t_subr (gdbscm_value_optimized_out_p),
1427     "\
1428 Return #t if the value has been optimizd out." },
1429
1430   { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address),
1431     "\
1432 Return the address of the value." },
1433
1434   { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type),
1435     "\
1436 Return the type of the value." },
1437
1438   { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type),
1439     "\
1440 Return the dynamic type of the value." },
1441
1442   { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast),
1443     "\
1444 Cast the value to the supplied type.\n\
1445 \n\
1446   Arguments: <gdb:value> <gdb:type>" },
1447
1448   { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast),
1449     "\
1450 Cast the value to the supplied type, as if by the C++\n\
1451 dynamic_cast operator.\n\
1452 \n\
1453   Arguments: <gdb:value> <gdb:type>" },
1454
1455   { "value-reinterpret-cast", 2, 0, 0,
1456     as_a_scm_t_subr (gdbscm_value_reinterpret_cast),
1457     "\
1458 Cast the value to the supplied type, as if by the C++\n\
1459 reinterpret_cast operator.\n\
1460 \n\
1461   Arguments: <gdb:value> <gdb:type>" },
1462
1463   { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference),
1464     "\
1465 Return the result of applying the C unary * operator to the value." },
1466
1467   { "value-referenced-value", 1, 0, 0,
1468     as_a_scm_t_subr (gdbscm_value_referenced_value),
1469     "\
1470 Given a value of a reference type, return the value referenced.\n\
1471 The difference between this function and value-dereference is that\n\
1472 the latter applies * unary operator to a value, which need not always\n\
1473 result in the value referenced.\n\
1474 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1475 value-dereference will result in a value of type 'int' while\n\
1476 value-referenced-value will result in a value of type 'int *'." },
1477
1478   { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field),
1479     "\
1480 Return the specified field of the value.\n\
1481 \n\
1482   Arguments: <gdb:value> string" },
1483
1484   { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript),
1485     "\
1486 Return the value of the array at the specified index.\n\
1487 \n\
1488   Arguments: <gdb:value> integer" },
1489
1490   { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call),
1491     "\
1492 Perform an inferior function call taking the value as a pointer to the\n\
1493 function to call.\n\
1494 Each element of the argument list must be a <gdb:value> object or an object\n\
1495 that can be converted to one.\n\
1496 The result is the value returned by the function.\n\
1497 \n\
1498   Arguments: <gdb:value> arg-list" },
1499
1500   { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool),
1501     "\
1502 Return the Scheme boolean representing the GDB value.\n\
1503 The value must be \"integer like\".  Pointers are ok." },
1504
1505   { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer),
1506     "\
1507 Return the Scheme integer representing the GDB value.\n\
1508 The value must be \"integer like\".  Pointers are ok." },
1509
1510   { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real),
1511     "\
1512 Return the Scheme real number representing the GDB value.\n\
1513 The value must be a number." },
1514
1515   { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector),
1516     "\
1517 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1518 No transformation, endian or otherwise, is performed." },
1519
1520   { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string),
1521     "\
1522 Return the Unicode string of the value's contents.\n\
1523 If ENCODING is not given, the string is assumed to be encoded in\n\
1524 the target's charset.\n\
1525 An error setting \"error\" causes an exception to be thrown if there's\n\
1526 a decoding error.  An error setting of \"substitute\" causes invalid\n\
1527 characters to be replaced with \"?\".  The default is \"error\".\n\
1528 If LENGTH is provided, only fetch string to the length provided.\n\
1529 \n\
1530   Arguments: <gdb:value>\n\
1531              [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1532              [#:length length]" },
1533
1534   { "value->lazy-string", 1, 0, 1,
1535     as_a_scm_t_subr (gdbscm_value_to_lazy_string),
1536     "\
1537 Return a Scheme object representing a lazily fetched Unicode string\n\
1538 of the value's contents.\n\
1539 If ENCODING is not given, the string is assumed to be encoded in\n\
1540 the target's charset.\n\
1541 If LENGTH is provided, only fetch string to the length provided.\n\
1542 \n\
1543   Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1544
1545   { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p),
1546     "\
1547 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1548 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1549 is called." },
1550
1551   { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value),
1552     "\
1553 Create a <gdb:value> that will be lazily fetched from the target.\n\
1554 \n\
1555   Arguments: <gdb:type> address" },
1556
1557   { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x),
1558     "\
1559 Fetch the value from the inferior, if it was lazy.\n\
1560 The result is \"unspecified\"." },
1561
1562   { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print),
1563     "\
1564 Return the string representation (print form) of the value." },
1565
1566   { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval),
1567     "\
1568 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1569
1570   { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref),
1571     "\
1572 Return the specified value from GDB's value history." },
1573
1574   { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x),
1575     "\
1576 Append the specified value onto GDB's value history." },
1577
1578   END_FUNCTIONS
1579 };
1580
1581 void
1582 gdbscm_initialize_values (void)
1583 {
1584   value_smob_tag = gdbscm_make_smob_type (value_smob_name,
1585                                           sizeof (value_smob));
1586   scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
1587   scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
1588   scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
1589
1590   gdbscm_define_functions (value_functions, 1);
1591
1592   type_keyword = scm_from_latin1_keyword ("type");
1593   encoding_keyword = scm_from_latin1_keyword ("encoding");
1594   errors_keyword = scm_from_latin1_keyword ("errors");
1595   length_keyword = scm_from_latin1_keyword ("length");
1596
1597   error_symbol = scm_from_latin1_symbol ("error");
1598   escape_symbol = scm_from_latin1_symbol ("escape");
1599   substitute_symbol = scm_from_latin1_symbol ("substitute");
1600 }