aboutsummaryrefslogtreecommitdiff
path: root/gdb/guile/scm-value.c
diff options
context:
space:
mode:
authorDoug Evans <xdje42@gmail.com>2014-02-09 19:40:01 -0800
committerDoug Evans <xdje42@gmail.com>2014-02-09 19:40:01 -0800
commited3ef33944c39d9a3cea72b9a7cef3c20f0e3461 (patch)
tree4e67d95b8ea65bb36a9cade5e37df2ad6289052e /gdb/guile/scm-value.c
parent7026a7c16ee82d39e84823f8cc3097a9a940ddb2 (diff)
downloadgdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.zip
gdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.gz
gdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.bz2
Add Guile as an extension language.
* NEWS: Mention Guile scripting. * Makefile.in (SUBDIR_GUILE_OBS): New variable. (SUBDIR_GUILE_SRCS, SUBDIR_GUILE_DEPS): New variables (SUBDIR_GUILE_LDFLAGS, SUBDIR_GUILE_CFLAGS): New variables. (INTERNAL_CPPFLAGS): Add GUILE_CPPFLAGS. (CLIBS): Add GUILE_LIBS. (install-guile): New rule. (guile.o): New rule. (scm-arch.o, scm-auto-load.o, scm-block.o): New rules. (scm-breakpoint.o, scm-disasm.o, scm-exception.o): New rules. (scm-frame.o, scm-iterator.o, scm-lazy-string.o): New rules. (scm-math.o, scm-objfile.o, scm-ports.o): New rules. (scm-pretty-print.o, scm-safe-call.o, scm-gsmob.o): New rules. (scm-string.o, scm-symbol.o, scm-symtab.o): New rules. (scm-type.o, scm-utils.o, scm-value.o): New rules. * configure.ac: New option --with-guile. * configure: Regenerate. * config.in: Regenerate. * auto-load.c: Remove #include "python/python.h". Add #include "gdb/section-scripts.h". (source_section_scripts): Handle Guile scripts. (_initialize_auto_load): Add name of Guile objfile script to scripts-directory help text. * breakpoint.c (condition_command): Tweak comment to include Scheme. * breakpoint.h (gdbscm_breakpoint_object): Add forward decl. (struct breakpoint): New member scm_bp_object. * defs.h (enum command_control_type): New value guile_control. * cli/cli-cmds.c: Remove #include "python/python.h". Add #include "extension.h". (show_user): Update comment. (_initialize_cli_cmds): Update help text for "show user". Update help text for max-user-call-depth. * cli/cli-script.c: Remove #include "python/python.h". Add #include "extension.h". (multi_line_command_p): Add guile_control. (print_command_lines): Handle guile_control. (execute_control_command, recurse_read_control_structure): Ditto. (process_next_line): Recognize "guile" commands. * disasm.c (gdb_disassemble_info): Make non-static. * disasm.h: #include "dis-asm.h". (struct gdbarch): Add forward decl. (gdb_disassemble_info): Declare. * extension.c: #include "guile/guile.h". (extension_languages): Add guile. (get_ext_lang_defn): Handle EXT_LANG_GDB. * extension.h (enum extension_language): New value EXT_LANG_GUILE. * gdbtypes.c (get_unsigned_type_max): New function. (get_signed_type_minmax): New function. * gdbtypes.h (get_unsigned_type_max): Declare. (get_signed_type_minmax): Declare. * guile/README: New file. * guile/guile-internal.h: New file. * guile/guile.c: New file. * guile/guile.h: New file. * guile/scm-arch.c: New file. * guile/scm-auto-load.c: New file. * guile/scm-block.c: New file. * guile/scm-breakpoint.c: New file. * guile/scm-disasm.c: New file. * guile/scm-exception.c: New file. * guile/scm-frame.c: New file. * guile/scm-gsmob.c: New file. * guile/scm-iterator.c: New file. * guile/scm-lazy-string.c: New file. * guile/scm-math.c: New file. * guile/scm-objfile.c: New file. * guile/scm-ports.c: New file. * guile/scm-pretty-print.c: New file. * guile/scm-safe-call.c: New file. * guile/scm-string.c: New file. * guile/scm-symbol.c: New file. * guile/scm-symtab.c: New file. * guile/scm-type.c: New file. * guile/scm-utils.c: New file. * guile/scm-value.c: New file. * guile/lib/gdb.scm: New file. * guile/lib/gdb/boot.scm: New file. * guile/lib/gdb/experimental.scm: New file. * guile/lib/gdb/init.scm: New file. * guile/lib/gdb/iterator.scm: New file. * guile/lib/gdb/printing.scm: New file. * guile/lib/gdb/types.scm: New file. * data-directory/Makefile.in (GUILE_SRCDIR): New variable. (VPATH): Add $(GUILE_SRCDIR). (GUILE_DIR): New variable. (GUILE_INSTALL_DIR, GUILE_FILES): New variables. (all): Add stamp-guile dependency. (stamp-guile): New rule. (clean-guile, install-guile, uninstall-guile): New rules. (install-only): Add install-guile dependency. (uninstall): Add uninstall-guile dependency. (clean): Add clean-guile dependency. doc/ * Makefile.in (GDB_DOC_FILES): Add guile.texi. * gdb.texinfo (Auto-loading): Add set/show auto-load guile-scripts. (Extending GDB): New menu entries Guile, Multiple Extension Languages. (Guile docs): Include guile.texi. (objfile-gdbdotext file): Add objfile-gdb.scm. (dotdebug_gdb_scripts section): Mention Guile scripts. (Multiple Extension Languages): New node. * guile.texi: New file. testsuite/ * configure.ac (AC_OUTPUT): Add gdb.guile. * configure: Regenerate. * lib/gdb-guile.exp: New file. * lib/gdb.exp (get_target_charset): New function. * gdb.base/help.exp: Update expected output from "apropos apropos". * gdb.guile/Makefile.in: New file. * gdb.guile/guile.exp: New file. * gdb.guile/scm-arch.c: New file. * gdb.guile/scm-arch.exp: New file. * gdb.guile/scm-block.c: New file. * gdb.guile/scm-block.exp: New file. * gdb.guile/scm-breakpoint.c: New file. * gdb.guile/scm-breakpoint.exp: New file. * gdb.guile/scm-disasm.c: New file. * gdb.guile/scm-disasm.exp: New file. * gdb.guile/scm-equal.c: New file. * gdb.guile/scm-equal.exp: New file. * gdb.guile/scm-error.exp: New file. * gdb.guile/scm-error.scm: New file. * gdb.guile/scm-frame-args.c: New file. * gdb.guile/scm-frame-args.exp: New file. * gdb.guile/scm-frame-args.scm: New file. * gdb.guile/scm-frame-inline.c: New file. * gdb.guile/scm-frame-inline.exp: New file. * gdb.guile/scm-frame.c: New file. * gdb.guile/scm-frame.exp: New file. * gdb.guile/scm-generics.exp: New file. * gdb.guile/scm-gsmob.exp: New file. * gdb.guile/scm-iterator.c: New file. * gdb.guile/scm-iterator.exp: New file. * gdb.guile/scm-math.c: New file. * gdb.guile/scm-math.exp: New file. * gdb.guile/scm-objfile-script-gdb.in: New file. * gdb.guile/scm-objfile-script.c: New file. * gdb.guile/scm-objfile-script.exp: New file. * gdb.guile/scm-objfile.c: New file. * gdb.guile/scm-objfile.exp: New file. * gdb.guile/scm-ports.exp: New file. * gdb.guile/scm-pretty-print.c: New file. * gdb.guile/scm-pretty-print.exp: New file. * gdb.guile/scm-pretty-print.scm: New file. * gdb.guile/scm-section-script.c: New file. * gdb.guile/scm-section-script.exp: New file. * gdb.guile/scm-section-script.scm: New file. * gdb.guile/scm-symbol.c: New file. * gdb.guile/scm-symbol.exp: New file. * gdb.guile/scm-symtab-2.c: New file. * gdb.guile/scm-symtab.c: New file. * gdb.guile/scm-symtab.exp: New file. * gdb.guile/scm-type.c: New file. * gdb.guile/scm-type.exp: New file. * gdb.guile/scm-value-cc.cc: New file. * gdb.guile/scm-value-cc.exp: New file. * gdb.guile/scm-value.c: New file. * gdb.guile/scm-value.exp: New file. * gdb.guile/source2.scm: New file. * gdb.guile/types-module.cc: New file. * gdb.guile/types-module.exp: New file.
Diffstat (limited to 'gdb/guile/scm-value.c')
-rw-r--r--gdb/guile/scm-value.c1485
1 files changed, 1485 insertions, 0 deletions
diff --git a/gdb/guile/scm-value.c b/gdb/guile/scm-value.c
new file mode 100644
index 0000000..f7f27cee
--- /dev/null
+++ b/gdb/guile/scm-value.c
@@ -0,0 +1,1485 @@
+/* Scheme interface to values.
+
+ Copyright (C) 2008-2014 Free Software Foundation, Inc.
+
+ This file is part of GDB.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+#include "defs.h"
+#include "arch-utils.h"
+#include "charset.h"
+#include "cp-abi.h"
+#include "gdb_assert.h"
+#include "infcall.h"
+#include "symtab.h" /* Needed by language.h. */
+#include "language.h"
+#include "valprint.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* The <gdb:value> smob. */
+
+typedef struct _value_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* Doubly linked list of values in values_in_scheme.
+ IWBN to use a chained_gdb_smob instead, which is doable, it just requires
+ a bit more casting than normal. */
+ struct _value_smob *next;
+ struct _value_smob *prev;
+
+ struct value *value;
+
+ /* These are cached here to avoid making multiple copies of them.
+ Plus computing the dynamic_type can be a bit expensive.
+ We use #f to indicate that the value doesn't exist (e.g. value doesn't
+ have an address), so we need another value to indicate that we haven't
+ computed the value yet. For this we use SCM_UNDEFINED. */
+ SCM address;
+ SCM type;
+ SCM dynamic_type;
+} value_smob;
+
+static const char value_smob_name[] = "gdb:value";
+
+/* The tag Guile knows the value smob by. */
+static scm_t_bits value_smob_tag;
+
+/* List of all values which are currently exposed to Scheme. It is
+ maintained so that when an objfile is discarded, preserve_values
+ can copy the values' types if needed. */
+static value_smob *values_in_scheme;
+
+/* Keywords used by Scheme procedures in this file. */
+static SCM type_keyword;
+static SCM encoding_keyword;
+static SCM errors_keyword;
+static SCM length_keyword;
+
+/* Possible #:errors values. */
+static SCM error_symbol;
+static SCM escape_symbol;
+static SCM substitute_symbol;
+
+/* Administrivia for value smobs. */
+
+/* Iterate over all the <gdb:value> objects, calling preserve_one_value on
+ each.
+ This is the extension_language_ops.preserve_values "method". */
+
+void
+gdbscm_preserve_values (const struct extension_language_defn *extlang,
+ struct objfile *objfile, htab_t copied_types)
+{
+ value_smob *iter;
+
+ for (iter = values_in_scheme; iter; iter = iter->next)
+ preserve_one_value (iter->value, objfile, copied_types);
+}
+
+/* Helper to add a value_smob to the global list. */
+
+static void
+vlscm_remember_scheme_value (value_smob *v_smob)
+{
+ v_smob->next = values_in_scheme;
+ if (v_smob->next)
+ v_smob->next->prev = v_smob;
+ v_smob->prev = NULL;
+ values_in_scheme = v_smob;
+}
+
+/* Helper to remove a value_smob from the global list. */
+
+static void
+vlscm_forget_value_smob (value_smob *v_smob)
+{
+ /* Remove SELF from the global list. */
+ if (v_smob->prev)
+ v_smob->prev->next = v_smob->next;
+ else
+ {
+ gdb_assert (values_in_scheme == v_smob);
+ values_in_scheme = v_smob->next;
+ }
+ if (v_smob->next)
+ v_smob->next->prev = v_smob->prev;
+}
+
+/* The smob "mark" function for <gdb:value>. */
+
+static SCM
+vlscm_mark_value_smob (SCM self)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (v_smob->address);
+ scm_gc_mark (v_smob->type);
+ scm_gc_mark (v_smob->dynamic_type);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&v_smob->base);
+}
+
+/* The smob "free" function for <gdb:value>. */
+
+static size_t
+vlscm_free_value_smob (SCM self)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+
+ vlscm_forget_value_smob (v_smob);
+ value_free (v_smob->value);
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:value>. */
+
+static int
+vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+ char *s = NULL;
+ struct value_print_options opts;
+ volatile struct gdb_exception except;
+
+ if (pstate->writingp)
+ gdbscm_printf (port, "#<%s ", value_smob_name);
+
+ get_user_print_options (&opts);
+ opts.deref_ref = 0;
+
+ /* pstate->writingp = zero if invoked by display/~A, and nonzero if
+ invoked by write/~S. What to do here may need to evolve.
+ IWBN if we could pass an argument to format that would we could use
+ instead of writingp. */
+ opts.raw = !!pstate->writingp;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct ui_file *stb = mem_fileopen ();
+ struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
+
+ common_val_print (v_smob->value, stb, 0, &opts, current_language);
+ s = ui_file_xstrdup (stb, NULL);
+
+ do_cleanups (old_chain);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (s != NULL)
+ {
+ scm_puts (s, port);
+ xfree (s);
+ }
+
+ if (pstate->writingp)
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* The smob "equalp" function for <gdb:value>. */
+
+static SCM
+vlscm_equal_p_value_smob (SCM v1, SCM v2)
+{
+ const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
+ const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
+ int result = 0;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ result = value_equal (v1_smob->value, v2_smob->value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (result);
+}
+
+/* Low level routine to create a <gdb:value> object. */
+
+static SCM
+vlscm_make_value_smob (void)
+{
+ value_smob *v_smob = (value_smob *)
+ scm_gc_malloc (sizeof (value_smob), value_smob_name);
+ SCM v_scm;
+
+ /* These must be filled in by the caller. */
+ v_smob->value = NULL;
+ v_smob->prev = NULL;
+ v_smob->next = NULL;
+
+ /* These are lazily computed. */
+ v_smob->address = SCM_UNDEFINED;
+ v_smob->type = SCM_UNDEFINED;
+ v_smob->dynamic_type = SCM_UNDEFINED;
+
+ v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
+ gdbscm_init_gsmob (&v_smob->base);
+
+ return v_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:value> object. */
+
+int
+vlscm_is_value (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (value_smob_tag, scm);
+}
+
+/* (value? object) -> boolean */
+
+static SCM
+gdbscm_value_p (SCM scm)
+{
+ return scm_from_bool (vlscm_is_value (scm));
+}
+
+/* Create a new <gdb:value> object that encapsulates VALUE.
+ The value is released from the all_values chain so its lifetime is not
+ bound to the execution of a command. */
+
+SCM
+vlscm_scm_from_value (struct value *value)
+{
+ /* N.B. It's important to not cause any side-effects until we know the
+ conversion worked. */
+ SCM v_scm = vlscm_make_value_smob ();
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+
+ v_smob->value = value;
+ release_value_or_incref (value);
+ vlscm_remember_scheme_value (v_smob);
+
+ return v_scm;
+}
+
+/* Returns the <gdb:value> object in SELF.
+ Throws an exception if SELF is not a <gdb:value> object. */
+
+static SCM
+vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
+ value_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the value smob of SELF.
+ Throws an exception if SELF is not a <gdb:value> object. */
+
+static value_smob *
+vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+
+ return v_smob;
+}
+
+/* Return the value field of V_SCM, an object of type <gdb:value>.
+ This exists so that we don't have to export the struct's contents. */
+
+struct value *
+vlscm_scm_to_value (SCM v_scm)
+{
+ value_smob *v_smob;
+
+ gdb_assert (vlscm_is_value (v_scm));
+ v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+ return v_smob->value;
+}
+
+/* Value methods. */
+
+/* (make-value x [#:type type]) -> <gdb:value> */
+
+static SCM
+gdbscm_make_value (SCM x, SCM rest)
+{
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ const SCM keywords[] = { type_keyword, SCM_BOOL_F };
+ int type_arg_pos = -1;
+ SCM type_scm = SCM_UNDEFINED;
+ SCM except_scm, result;
+ type_smob *t_smob;
+ struct type *type = NULL;
+ struct value *value;
+ struct cleanup *cleanups;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
+ &type_arg_pos, &type_scm);
+
+ if (type_arg_pos > 0)
+ {
+ t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
+ FUNC_NAME);
+ type = tyscm_type_smob_type (t_smob);
+ }
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
+ type_arg_pos, type_scm, type,
+ &except_scm,
+ gdbarch, language);
+ if (value == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ result = vlscm_scm_from_value (value);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+ return result;
+}
+
+/* (make-lazy-value <gdb:type> address) -> <gdb:value> */
+
+static SCM
+gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
+{
+ type_smob *t_smob;
+ struct type *type;
+ ULONGEST address;
+ struct value *value = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
+ type = tyscm_type_smob_type (t_smob);
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
+ address_scm, &address);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
+ and future-proofing we do. */
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ value = value_from_contents_and_address (type, NULL, address);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (value);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+ return result;
+}
+
+/* (value-optimized-out? <gdb:value>) -> boolean */
+
+static SCM
+gdbscm_value_optimized_out_p (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ int opt = 0;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ opt = value_optimized_out (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (opt);
+}
+
+/* (value-address <gdb:value>) -> integer
+ Returns #f if the value doesn't have one. */
+
+static SCM
+gdbscm_value_address (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ if (SCM_UNBNDP (v_smob->address))
+ {
+ struct value *res_val = NULL;
+ struct cleanup *cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+ SCM address;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = value_addr (value);
+ }
+ if (except.reason < 0)
+ address = SCM_BOOL_F;
+ else
+ address = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanup);
+
+ if (gdbscm_is_exception (address))
+ gdbscm_throw (address);
+
+ v_smob->address = address;
+ }
+
+ return v_smob->address;
+}
+
+/* (value-dereference <gdb:value>) -> <gdb:value>
+ Given a value of a pointer type, apply the C unary * operator to it. */
+
+static SCM
+gdbscm_value_dereference (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = value_ind (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-referenced-value <gdb:value>) -> <gdb:value>
+ Given a value of a reference type, return the value referenced.
+ The difference between this function and gdbscm_value_dereference is that
+ the latter applies * unary operator to a value, which need not always
+ result in the value referenced.
+ For example, for a value which is a reference to an 'int' pointer ('int *'),
+ gdbscm_value_dereference will result in a value of type 'int' while
+ gdbscm_value_referenced_value will result in a value of type 'int *'. */
+
+static SCM
+gdbscm_value_referenced_value (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ switch (TYPE_CODE (check_typedef (value_type (value))))
+ {
+ case TYPE_CODE_PTR:
+ res_val = value_ind (value);
+ break;
+ case TYPE_CODE_REF:
+ res_val = coerce_ref (value);
+ break;
+ default:
+ error (_("Trying to get the referenced value from a value which is"
+ " neither a pointer nor a reference"));
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-type <gdb:value>) -> <gdb:type> */
+
+static SCM
+gdbscm_value_type (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ if (SCM_UNBNDP (v_smob->type))
+ v_smob->type = tyscm_scm_from_type (value_type (value));
+
+ return v_smob->type;
+}
+
+/* (value-dynamic-type <gdb:value>) -> <gdb:type> */
+
+static SCM
+gdbscm_value_dynamic_type (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type = NULL;
+ volatile struct gdb_exception except;
+
+ if (! SCM_UNBNDP (v_smob->type))
+ return v_smob->dynamic_type;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+
+ type = value_type (value);
+ CHECK_TYPEDEF (type);
+
+ if (((TYPE_CODE (type) == TYPE_CODE_PTR)
+ || (TYPE_CODE (type) == TYPE_CODE_REF))
+ && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CLASS))
+ {
+ struct value *target;
+ int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
+
+ target = value_ind (value);
+ type = value_rtti_type (target, NULL, NULL, NULL);
+
+ if (type)
+ {
+ if (was_pointer)
+ type = lookup_pointer_type (type);
+ else
+ type = lookup_reference_type (type);
+ }
+ }
+ else if (TYPE_CODE (type) == TYPE_CODE_CLASS)
+ type = value_rtti_type (value, NULL, NULL, NULL);
+ else
+ {
+ /* Re-use object's static type. */
+ type = NULL;
+ }
+
+ do_cleanups (cleanup);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (type == NULL)
+ v_smob->dynamic_type = gdbscm_value_type (self);
+ else
+ v_smob->dynamic_type = tyscm_scm_from_type (type);
+
+ return v_smob->dynamic_type;
+}
+
+/* A helper function that implements the various cast operators. */
+
+static SCM
+vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
+ const char *func_name)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
+ struct type *type = tyscm_type_smob_type (t_smob);
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (op == UNOP_DYNAMIC_CAST)
+ res_val = value_dynamic_cast (type, value);
+ else if (op == UNOP_REINTERPRET_CAST)
+ res_val = value_reinterpret_cast (type, value);
+ else
+ {
+ gdb_assert (op == UNOP_CAST);
+ res_val = value_cast (type, value);
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
+}
+
+/* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_dynamic_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
+}
+
+/* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
+}
+
+/* (value-field <gdb:value> string) -> <gdb:value>
+ Given string name of an element inside structure, return its <gdb:value>
+ object. */
+
+static SCM
+gdbscm_value_field (SCM self, SCM field_scm)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ char *field = NULL;
+ struct value *res_val = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
+ _("string"));
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ field = gdbscm_scm_to_c_string (field_scm);
+ make_cleanup (xfree, field);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct value *tmp = value;
+
+ res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
+ Return the specified value in an array. */
+
+static SCM
+gdbscm_value_subscript (SCM self, SCM index_scm)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct value *index = NULL;
+ struct value *res_val = NULL;
+ struct type *type = value_type (value);
+ struct gdbarch *gdbarch;
+ SCM result, except_scm;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
+ gdbarch = get_type_arch (type);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
+ &except_scm,
+ gdbarch, current_language);
+ if (index == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct value *tmp = value;
+
+ /* Assume we are attempting an array access, and let the value code
+ throw an exception if the index has an invalid type.
+ Check the value's type is something that can be accessed via
+ a subscript. */
+ tmp = coerce_ref (tmp);
+ type = check_typedef (value_type (tmp));
+ if (TYPE_CODE (type) != TYPE_CODE_ARRAY
+ && TYPE_CODE (type) != TYPE_CODE_PTR)
+ error (_("Cannot subscript requested type"));
+
+ res_val = value_subscript (tmp, value_as_long (index));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-call <gdb:value> arg-list) -> <gdb:value>
+ Perform an inferior function call on the value. */
+
+static SCM
+gdbscm_value_call (SCM self, SCM args)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *function = v_smob->value;
+ struct value *mark = value_mark ();
+ struct type *ftype = NULL;
+ long args_count;
+ struct value **vargs = NULL;
+ SCM result = SCM_BOOL_F;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ ftype = check_typedef (value_type (function));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
+ SCM_ARG1, FUNC_NAME,
+ _("function (value of TYPE_CODE_FUNC)"));
+
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
+ SCM_ARG2, FUNC_NAME, _("list"));
+
+ args_count = scm_ilength (args);
+ if (args_count > 0)
+ {
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ SCM except_scm;
+ long i;
+
+ vargs = alloca (sizeof (struct value *) * args_count);
+ for (i = 0; i < args_count; i++)
+ {
+ SCM arg = scm_car (args);
+
+ vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
+ GDBSCM_ARG_NONE, arg,
+ &except_scm,
+ gdbarch, language);
+ if (vargs[i] == NULL)
+ gdbscm_throw (except_scm);
+
+ args = scm_cdr (args);
+ }
+ gdb_assert (gdbscm_is_true (scm_null_p (args)));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
+ struct value *return_value;
+
+ return_value = call_function_by_hand (function, args_count, vargs);
+ result = vlscm_scm_from_value (return_value);
+ do_cleanups (cleanup);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value->bytevector <gdb:value>) -> bytevector */
+
+static SCM
+gdbscm_value_to_bytevector (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ size_t length = 0;
+ const gdb_byte *contents = NULL;
+ SCM bv;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ length = TYPE_LENGTH (type);
+ contents = value_contents (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ bv = scm_c_make_bytevector (length);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
+
+ return bv;
+}
+
+/* Helper function to determine if a type is "int-like". */
+
+static int
+is_intlike (struct type *type, int ptr_ok)
+{
+ return (TYPE_CODE (type) == TYPE_CODE_INT
+ || TYPE_CODE (type) == TYPE_CODE_ENUM
+ || TYPE_CODE (type) == TYPE_CODE_BOOL
+ || TYPE_CODE (type) == TYPE_CODE_CHAR
+ || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
+}
+
+/* (value->bool <gdb:value>) -> boolean
+ Throws an error if the value is not integer-like. */
+
+static SCM
+gdbscm_value_to_bool (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ LONGEST l = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
+ _("integer-like gdb value"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ l = value_as_address (value);
+ else
+ l = value_as_long (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (l != 0);
+}
+
+/* (value->integer <gdb:value>) -> integer
+ Throws an error if the value is not integer-like. */
+
+static SCM
+gdbscm_value_to_integer (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ LONGEST l = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
+ _("integer-like gdb value"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ l = value_as_address (value);
+ else
+ l = value_as_long (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (TYPE_UNSIGNED (type))
+ return gdbscm_scm_from_ulongest (l);
+ else
+ return gdbscm_scm_from_longest (l);
+}
+
+/* (value->real <gdb:value>) -> real
+ Throws an error if the value is not a number. */
+
+static SCM
+gdbscm_value_to_real (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ DOUBLEST d = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
+ self, SCM_ARG1, FUNC_NAME, _("number"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ d = value_as_double (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ /* TODO: Is there a better way to check if the value fits? */
+ if (d != (double) d)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _("number can't be converted to a double"));
+
+ return scm_from_double (d);
+}
+
+/* (value->string <gdb:value>
+ [#:encoding encoding]
+ [#:errors #f | 'error | 'substitute]
+ [#:length length])
+ -> string
+ Return Unicode string with value's contents, which must be a string.
+
+ If ENCODING is not given, the string is assumed to be encoded in
+ the target's charset.
+
+ ERRORS is one of #f, 'error or 'substitute.
+ An error setting of #f means use the default, which is
+ Guile's %default-port-conversion-strategy. If the default is not one
+ of 'error or 'substitute, 'substitute is used.
+ An error setting of "error" causes an exception to be thrown if there's
+ a decoding error. An error setting of "substitute" causes invalid
+ characters to be replaced with "?".
+
+ If LENGTH is provided, only fetch string to the length provided.
+ LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
+
+static SCM
+gdbscm_value_to_string (SCM self, SCM rest)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ const SCM keywords[] = {
+ encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
+ };
+ int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
+ char *encoding = NULL;
+ SCM errors = SCM_BOOL_F;
+ int length = -1;
+ gdb_byte *buffer = NULL;
+ const char *la_encoding = NULL;
+ struct type *char_type = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
+ &encoding_arg_pos, &encoding,
+ &errors_arg_pos, &errors,
+ &length_arg_pos, &length);
+
+ cleanups = make_cleanup (xfree, encoding);
+
+ if (errors_arg_pos > 0
+ && errors != SCM_BOOL_F
+ && !scm_is_eq (errors, error_symbol)
+ && !scm_is_eq (errors, substitute_symbol))
+ {
+ SCM excp
+ = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
+ _("invalid error kind"));
+
+ do_cleanups (cleanups);
+ gdbscm_throw (excp);
+ }
+ if (errors == SCM_BOOL_F)
+ errors = scm_port_conversion_strategy (SCM_BOOL_F);
+ /* We don't assume anything about the result of scm_port_conversion_strategy.
+ From this point on, if errors is not 'errors, use 'substitute. */
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ /* If errors is "error" scm_from_stringn may throw a Scheme exception.
+ Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
+ discard_cleanups (cleanups);
+
+ scm_dynwind_begin (0);
+
+ gdbscm_dynwind_xfree (encoding);
+ gdbscm_dynwind_xfree (buffer);
+
+ result = scm_from_stringn ((const char *) buffer,
+ length * TYPE_LENGTH (char_type),
+ (encoding != NULL && *encoding != '\0'
+ ? encoding
+ : la_encoding),
+ scm_is_eq (errors, error_symbol)
+ ? SCM_FAILED_CONVERSION_ERROR
+ : SCM_FAILED_CONVERSION_QUESTION_MARK);
+
+ scm_dynwind_end ();
+
+ return result;
+}
+
+/* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
+ -> <gdb:lazy-string>
+ Return a Scheme object representing a lazy_string_object type.
+ A lazy string is a pointer to a string with an optional encoding and length.
+ If ENCODING is not given, the target's charset is used.
+ If LENGTH is provided then the length parameter is set to LENGTH, otherwise
+ length will be set to -1 (first null of appropriate with).
+ LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
+
+static SCM
+gdbscm_value_to_lazy_string (SCM self, SCM rest)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
+ int encoding_arg_pos = -1, length_arg_pos = -1;
+ char *encoding = NULL;
+ int length = -1;
+ SCM result = SCM_BOOL_F; /* -Wall */
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
+ &encoding_arg_pos, &encoding,
+ &length_arg_pos, &length);
+
+ cleanups = make_cleanup (xfree, encoding);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *inner_cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+
+ if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
+ value = value_ind (value);
+
+ result = lsscm_make_lazy_string (value_address (value), length,
+ encoding, value_type (value));
+
+ do_cleanups (inner_cleanup);
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-lazy? <gdb:value>) -> boolean */
+
+static SCM
+gdbscm_value_lazy_p (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ return scm_from_bool (value_lazy (value));
+}
+
+/* (value-fetch-lazy! <gdb:value>) -> unspecified */
+
+static SCM
+gdbscm_value_fetch_lazy_x (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (value_lazy (value))
+ value_fetch_lazy (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (value-print <gdb:value>) -> string */
+
+static SCM
+gdbscm_value_print (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct value_print_options opts;
+ char *s = NULL;
+ SCM result;
+ volatile struct gdb_exception except;
+
+ get_user_print_options (&opts);
+ opts.deref_ref = 0;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct ui_file *stb = mem_fileopen ();
+ struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
+
+ common_val_print (value, stb, 0, &opts, current_language);
+ s = ui_file_xstrdup (stb, NULL);
+
+ do_cleanups (old_chain);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
+ throw an error if the encoding fails.
+ IWBN to use scm_take_locale_string here, but we'd have to temporarily
+ override the default port conversion handler because contrary to
+ documentation it doesn't necessarily free the input string. */
+ result = scm_from_stringn (s, strlen (s), host_charset (),
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ xfree (s);
+
+ return result;
+}
+
+/* (parse-and-eval string) -> <gdb:value>
+ Parse a string and evaluate the string as an expression. */
+
+static SCM
+gdbscm_parse_and_eval (SCM expr_scm)
+{
+ char *expr_str;
+ struct value *res_val = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
+ expr_scm, &expr_str);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+ make_cleanup (xfree, expr_str);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = parse_and_eval (expr_str);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (history-ref integer) -> <gdb:value>
+ Return the specified value from GDB's value history. */
+
+static SCM
+gdbscm_history_ref (SCM index)
+{
+ int i;
+ struct value *res_val = NULL; /* Initialize to appease gcc warning. */
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = access_value_history (i);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return vlscm_scm_from_value (res_val);
+}
+
+/* Initialize the Scheme value code. */
+
+static const scheme_function value_functions[] =
+{
+ { "value?", 1, 0, 0, gdbscm_value_p,
+ "\
+Return #t if the object is a <gdb:value> object." },
+
+ { "make-value", 1, 0, 1, gdbscm_make_value,
+ "\
+Create a <gdb:value> representing object.\n\
+Typically this is used to convert numbers and strings to\n\
+<gdb:value> objects.\n\
+\n\
+ Arguments: object [#:type <gdb:type>]" },
+
+ { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
+ "\
+Return #t if the value has been optimizd out." },
+
+ { "value-address", 1, 0, 0, gdbscm_value_address,
+ "\
+Return the address of the value." },
+
+ { "value-type", 1, 0, 0, gdbscm_value_type,
+ "\
+Return the type of the value." },
+
+ { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
+ "\
+Return the dynamic type of the value." },
+
+ { "value-cast", 2, 0, 0, gdbscm_value_cast,
+ "\
+Cast the value to the supplied type.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
+ "\
+Cast the value to the supplied type, as if by the C++\n\
+dynamic_cast operator.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
+ "\
+Cast the value to the supplied type, as if by the C++\n\
+reinterpret_cast operator.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
+ "\
+Return the result of applying the C unary * operator to the value." },
+
+ { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
+ "\
+Given a value of a reference type, return the value referenced.\n\
+The difference between this function and value-dereference is that\n\
+the latter applies * unary operator to a value, which need not always\n\
+result in the value referenced.\n\
+For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
+value-dereference will result in a value of type 'int' while\n\
+value-referenced-value will result in a value of type 'int *'." },
+
+ { "value-field", 2, 0, 0, gdbscm_value_field,
+ "\
+Return the specified field of the value.\n\
+\n\
+ Arguments: <gdb:value> string" },
+
+ { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
+ "\
+Return the value of the array at the specified index.\n\
+\n\
+ Arguments: <gdb:value> integer" },
+
+ { "value-call", 2, 0, 0, gdbscm_value_call,
+ "\
+Perform an inferior function call taking the value as a pointer to the\n\
+function to call.\n\
+Each element of the argument list must be a <gdb:value> object or an object\n\
+that can be converted to one.\n\
+The result is the value returned by the function.\n\
+\n\
+ Arguments: <gdb:value> arg-list" },
+
+ { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
+ "\
+Return the Scheme boolean representing the GDB value.\n\
+The value must be \"integer like\". Pointers are ok." },
+
+ { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
+ "\
+Return the Scheme integer representing the GDB value.\n\
+The value must be \"integer like\". Pointers are ok." },
+
+ { "value->real", 1, 0, 0, gdbscm_value_to_real,
+ "\
+Return the Scheme real number representing the GDB value.\n\
+The value must be a number." },
+
+ { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
+ "\
+Return a Scheme bytevector with the raw contents of the GDB value.\n\
+No transformation, endian or otherwise, is performed." },
+
+ { "value->string", 1, 0, 1, gdbscm_value_to_string,
+ "\
+Return the Unicode string of the value's contents.\n\
+If ENCODING is not given, the string is assumed to be encoded in\n\
+the target's charset.\n\
+An error setting \"error\" causes an exception to be thrown if there's\n\
+a decoding error. An error setting of \"substitute\" causes invalid\n\
+characters to be replaced with \"?\". The default is \"error\".\n\
+If LENGTH is provided, only fetch string to the length provided.\n\
+\n\
+ Arguments: <gdb:value>\n\
+ [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
+ [#:length length]" },
+
+ { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
+ "\
+Return a Scheme object representing a lazily fetched Unicode string\n\
+of the value's contents.\n\
+If ENCODING is not given, the string is assumed to be encoded in\n\
+the target's charset.\n\
+If LENGTH is provided, only fetch string to the length provided.\n\
+\n\
+ Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
+
+ { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
+ "\
+Return #t if the value is lazy (not fetched yet from the inferior).\n\
+A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
+is called." },
+
+ { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
+ "\
+Create a <gdb:value> that will be lazily fetched from the target.\n\
+\n\
+ Arguments: <gdb:type> address" },
+
+ { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
+ "\
+Fetch the value from the inferior, if it was lazy.\n\
+The result is \"unspecified\"." },
+
+ { "value-print", 1, 0, 0, gdbscm_value_print,
+ "\
+Return the string representation (print form) of the value." },
+
+ { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
+ "\
+Evaluates string in gdb and returns the result as a <gdb:value> object." },
+
+ { "history-ref", 1, 0, 0, gdbscm_history_ref,
+ "\
+Return the specified value from GDB's value history." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_values (void)
+{
+ value_smob_tag = gdbscm_make_smob_type (value_smob_name,
+ sizeof (value_smob));
+ scm_set_smob_mark (value_smob_tag, vlscm_mark_value_smob);
+ scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
+ scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
+ scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
+
+ gdbscm_define_functions (value_functions, 1);
+
+ type_keyword = scm_from_latin1_keyword ("type");
+ encoding_keyword = scm_from_latin1_keyword ("encoding");
+ errors_keyword = scm_from_latin1_keyword ("errors");
+ length_keyword = scm_from_latin1_keyword ("length");
+
+ error_symbol = scm_from_latin1_symbol ("error");
+ escape_symbol = scm_from_latin1_symbol ("escape");
+ substitute_symbol = scm_from_latin1_symbol ("substitute");
+}