1 /* Scheme interface to values.
3 Copyright (C) 2008-2014 Free Software Foundation, Inc.
5 This file is part of GDB.
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.
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.
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/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
24 #include "arch-utils.h"
27 #include "gdb_assert.h"
29 #include "symtab.h" /* Needed by language.h. */
33 #include "guile-internal.h"
35 /* The <gdb:value> smob. */
37 typedef struct _value_smob
39 /* This always appears first. */
42 /* Doubly linked list of values in values_in_scheme.
43 IWBN to use a chained_gdb_smob instead, which is doable, it just requires
44 a bit more casting than normal. */
45 struct _value_smob *next;
46 struct _value_smob *prev;
50 /* These are cached here to avoid making multiple copies of them.
51 Plus computing the dynamic_type can be a bit expensive.
52 We use #f to indicate that the value doesn't exist (e.g. value doesn't
53 have an address), so we need another value to indicate that we haven't
54 computed the value yet. For this we use SCM_UNDEFINED. */
60 static const char value_smob_name[] = "gdb:value";
62 /* The tag Guile knows the value smob by. */
63 static scm_t_bits value_smob_tag;
65 /* List of all values which are currently exposed to Scheme. It is
66 maintained so that when an objfile is discarded, preserve_values
67 can copy the values' types if needed. */
68 static value_smob *values_in_scheme;
70 /* Keywords used by Scheme procedures in this file. */
71 static SCM type_keyword;
72 static SCM encoding_keyword;
73 static SCM errors_keyword;
74 static SCM length_keyword;
76 /* Possible #:errors values. */
77 static SCM error_symbol;
78 static SCM escape_symbol;
79 static SCM substitute_symbol;
81 /* Administrivia for value smobs. */
83 /* Iterate over all the <gdb:value> objects, calling preserve_one_value on
85 This is the extension_language_ops.preserve_values "method". */
88 gdbscm_preserve_values (const struct extension_language_defn *extlang,
89 struct objfile *objfile, htab_t copied_types)
93 for (iter = values_in_scheme; iter; iter = iter->next)
94 preserve_one_value (iter->value, objfile, copied_types);
97 /* Helper to add a value_smob to the global list. */
100 vlscm_remember_scheme_value (value_smob *v_smob)
102 v_smob->next = values_in_scheme;
104 v_smob->next->prev = v_smob;
106 values_in_scheme = v_smob;
109 /* Helper to remove a value_smob from the global list. */
112 vlscm_forget_value_smob (value_smob *v_smob)
114 /* Remove SELF from the global list. */
116 v_smob->prev->next = v_smob->next;
119 gdb_assert (values_in_scheme == v_smob);
120 values_in_scheme = v_smob->next;
123 v_smob->next->prev = v_smob->prev;
126 /* The smob "mark" function for <gdb:value>. */
129 vlscm_mark_value_smob (SCM self)
131 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
133 scm_gc_mark (v_smob->address);
134 scm_gc_mark (v_smob->type);
135 return v_smob->dynamic_type;
138 /* The smob "free" function for <gdb:value>. */
141 vlscm_free_value_smob (SCM self)
143 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
145 vlscm_forget_value_smob (v_smob);
146 value_free (v_smob->value);
151 /* The smob "print" function for <gdb:value>. */
154 vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
156 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
158 struct value_print_options opts;
159 volatile struct gdb_exception except;
161 if (pstate->writingp)
162 gdbscm_printf (port, "#<%s ", value_smob_name);
164 get_user_print_options (&opts);
167 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
168 invoked by write/~S. What to do here may need to evolve.
169 IWBN if we could pass an argument to format that would we could use
170 instead of writingp. */
171 opts.raw = !!pstate->writingp;
173 TRY_CATCH (except, RETURN_MASK_ALL)
175 struct ui_file *stb = mem_fileopen ();
176 struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
178 common_val_print (v_smob->value, stb, 0, &opts, current_language);
179 s = ui_file_xstrdup (stb, NULL);
181 do_cleanups (old_chain);
183 GDBSCM_HANDLE_GDB_EXCEPTION (except);
191 if (pstate->writingp)
192 scm_puts (">", port);
194 scm_remember_upto_here_1 (self);
196 /* Non-zero means success. */
200 /* The smob "equalp" function for <gdb:value>. */
203 vlscm_equal_p_value_smob (SCM v1, SCM v2)
205 const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
206 const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
208 volatile struct gdb_exception except;
210 TRY_CATCH (except, RETURN_MASK_ALL)
212 result = value_equal (v1_smob->value, v2_smob->value);
214 GDBSCM_HANDLE_GDB_EXCEPTION (except);
216 return scm_from_bool (result);
219 /* Low level routine to create a <gdb:value> object. */
222 vlscm_make_value_smob (void)
224 value_smob *v_smob = (value_smob *)
225 scm_gc_malloc (sizeof (value_smob), value_smob_name);
228 /* These must be filled in by the caller. */
229 v_smob->value = NULL;
233 /* These are lazily computed. */
234 v_smob->address = SCM_UNDEFINED;
235 v_smob->type = SCM_UNDEFINED;
236 v_smob->dynamic_type = SCM_UNDEFINED;
238 v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
239 gdbscm_init_gsmob (&v_smob->base);
244 /* Return non-zero if SCM is a <gdb:value> object. */
247 vlscm_is_value (SCM scm)
249 return SCM_SMOB_PREDICATE (value_smob_tag, scm);
252 /* (value? object) -> boolean */
255 gdbscm_value_p (SCM scm)
257 return scm_from_bool (vlscm_is_value (scm));
260 /* Create a new <gdb:value> object that encapsulates VALUE.
261 The value is released from the all_values chain so its lifetime is not
262 bound to the execution of a command. */
265 vlscm_scm_from_value (struct value *value)
267 /* N.B. It's important to not cause any side-effects until we know the
268 conversion worked. */
269 SCM v_scm = vlscm_make_value_smob ();
270 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
272 v_smob->value = value;
273 release_value_or_incref (value);
274 vlscm_remember_scheme_value (v_smob);
279 /* Returns the <gdb:value> object in SELF.
280 Throws an exception if SELF is not a <gdb:value> object. */
283 vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
285 SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
291 /* Returns a pointer to the value smob of SELF.
292 Throws an exception if SELF is not a <gdb:value> object. */
295 vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
297 SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
298 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
303 /* Return the value field of V_SCM, an object of type <gdb:value>.
304 This exists so that we don't have to export the struct's contents. */
307 vlscm_scm_to_value (SCM v_scm)
311 gdb_assert (vlscm_is_value (v_scm));
312 v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
313 return v_smob->value;
318 /* (make-value x [#:type type]) -> <gdb:value> */
321 gdbscm_make_value (SCM x, SCM rest)
323 struct gdbarch *gdbarch = get_current_arch ();
324 const struct language_defn *language = current_language;
325 const SCM keywords[] = { type_keyword, SCM_BOOL_F };
326 int type_arg_pos = -1;
327 SCM type_scm = SCM_UNDEFINED;
328 SCM except_scm, result;
330 struct type *type = NULL;
332 struct cleanup *cleanups;
334 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
335 &type_arg_pos, &type_scm);
337 if (type_arg_pos > 0)
339 t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
341 type = tyscm_type_smob_type (t_smob);
344 cleanups = make_cleanup_value_free_to_mark (value_mark ());
346 value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
347 type_arg_pos, type_scm, type,
352 do_cleanups (cleanups);
353 gdbscm_throw (except_scm);
356 result = vlscm_scm_from_value (value);
358 do_cleanups (cleanups);
360 if (gdbscm_is_exception (result))
361 gdbscm_throw (result);
365 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
368 gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
373 struct value *value = NULL;
375 struct cleanup *cleanups;
376 volatile struct gdb_exception except;
378 t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
379 type = tyscm_type_smob_type (t_smob);
381 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
382 address_scm, &address);
384 cleanups = make_cleanup_value_free_to_mark (value_mark ());
386 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
387 and future-proofing we do. */
388 TRY_CATCH (except, RETURN_MASK_ALL)
390 value = value_from_contents_and_address (type, NULL, address);
392 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
394 result = vlscm_scm_from_value (value);
396 do_cleanups (cleanups);
398 if (gdbscm_is_exception (result))
399 gdbscm_throw (result);
403 /* (value-optimized-out? <gdb:value>) -> boolean */
406 gdbscm_value_optimized_out_p (SCM self)
409 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
410 struct value *value = v_smob->value;
412 volatile struct gdb_exception except;
414 TRY_CATCH (except, RETURN_MASK_ALL)
416 opt = value_optimized_out (value);
418 GDBSCM_HANDLE_GDB_EXCEPTION (except);
420 return scm_from_bool (opt);
423 /* (value-address <gdb:value>) -> integer
424 Returns #f if the value doesn't have one. */
427 gdbscm_value_address (SCM self)
430 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
431 struct value *value = v_smob->value;
433 if (SCM_UNBNDP (v_smob->address))
435 struct value *res_val = NULL;
436 struct cleanup *cleanup
437 = make_cleanup_value_free_to_mark (value_mark ());
439 volatile struct gdb_exception except;
441 TRY_CATCH (except, RETURN_MASK_ALL)
443 res_val = value_addr (value);
445 if (except.reason < 0)
446 address = SCM_BOOL_F;
448 address = vlscm_scm_from_value (res_val);
450 do_cleanups (cleanup);
452 if (gdbscm_is_exception (address))
453 gdbscm_throw (address);
455 v_smob->address = address;
458 return v_smob->address;
461 /* (value-dereference <gdb:value>) -> <gdb:value>
462 Given a value of a pointer type, apply the C unary * operator to it. */
465 gdbscm_value_dereference (SCM self)
468 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
469 struct value *value = v_smob->value;
471 struct value *res_val = NULL;
472 struct cleanup *cleanups;
473 volatile struct gdb_exception except;
475 cleanups = make_cleanup_value_free_to_mark (value_mark ());
477 TRY_CATCH (except, RETURN_MASK_ALL)
479 res_val = value_ind (value);
481 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
483 result = vlscm_scm_from_value (res_val);
485 do_cleanups (cleanups);
487 if (gdbscm_is_exception (result))
488 gdbscm_throw (result);
493 /* (value-referenced-value <gdb:value>) -> <gdb:value>
494 Given a value of a reference type, return the value referenced.
495 The difference between this function and gdbscm_value_dereference is that
496 the latter applies * unary operator to a value, which need not always
497 result in the value referenced.
498 For example, for a value which is a reference to an 'int' pointer ('int *'),
499 gdbscm_value_dereference will result in a value of type 'int' while
500 gdbscm_value_referenced_value will result in a value of type 'int *'. */
503 gdbscm_value_referenced_value (SCM self)
506 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
507 struct value *value = v_smob->value;
509 struct value *res_val = NULL;
510 struct cleanup *cleanups;
511 volatile struct gdb_exception except;
513 cleanups = make_cleanup_value_free_to_mark (value_mark ());
515 TRY_CATCH (except, RETURN_MASK_ALL)
517 switch (TYPE_CODE (check_typedef (value_type (value))))
520 res_val = value_ind (value);
523 res_val = coerce_ref (value);
526 error (_("Trying to get the referenced value from a value which is"
527 " neither a pointer nor a reference"));
530 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
532 result = vlscm_scm_from_value (res_val);
534 do_cleanups (cleanups);
536 if (gdbscm_is_exception (result))
537 gdbscm_throw (result);
542 /* (value-type <gdb:value>) -> <gdb:type> */
545 gdbscm_value_type (SCM self)
548 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
549 struct value *value = v_smob->value;
551 if (SCM_UNBNDP (v_smob->type))
552 v_smob->type = tyscm_scm_from_type (value_type (value));
557 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
560 gdbscm_value_dynamic_type (SCM self)
563 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
564 struct value *value = v_smob->value;
565 struct type *type = NULL;
566 volatile struct gdb_exception except;
568 if (! SCM_UNBNDP (v_smob->type))
569 return v_smob->dynamic_type;
571 TRY_CATCH (except, RETURN_MASK_ALL)
573 struct cleanup *cleanup
574 = make_cleanup_value_free_to_mark (value_mark ());
576 type = value_type (value);
577 CHECK_TYPEDEF (type);
579 if (((TYPE_CODE (type) == TYPE_CODE_PTR)
580 || (TYPE_CODE (type) == TYPE_CODE_REF))
581 && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CLASS))
583 struct value *target;
584 int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
587 target = value_ind (value);
589 target = coerce_ref (value);
590 type = value_rtti_type (target, NULL, NULL, NULL);
595 type = lookup_pointer_type (type);
597 type = lookup_reference_type (type);
600 else if (TYPE_CODE (type) == TYPE_CODE_CLASS)
601 type = value_rtti_type (value, NULL, NULL, NULL);
604 /* Re-use object's static type. */
608 do_cleanups (cleanup);
610 GDBSCM_HANDLE_GDB_EXCEPTION (except);
613 v_smob->dynamic_type = gdbscm_value_type (self);
615 v_smob->dynamic_type = tyscm_scm_from_type (type);
617 return v_smob->dynamic_type;
620 /* A helper function that implements the various cast operators. */
623 vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
624 const char *func_name)
627 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
628 struct value *value = v_smob->value;
630 = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
631 struct type *type = tyscm_type_smob_type (t_smob);
633 struct value *res_val = NULL;
634 struct cleanup *cleanups;
635 volatile struct gdb_exception except;
637 cleanups = make_cleanup_value_free_to_mark (value_mark ());
639 TRY_CATCH (except, RETURN_MASK_ALL)
641 if (op == UNOP_DYNAMIC_CAST)
642 res_val = value_dynamic_cast (type, value);
643 else if (op == UNOP_REINTERPRET_CAST)
644 res_val = value_reinterpret_cast (type, value);
647 gdb_assert (op == UNOP_CAST);
648 res_val = value_cast (type, value);
651 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
653 gdb_assert (res_val != NULL);
654 result = vlscm_scm_from_value (res_val);
656 do_cleanups (cleanups);
658 if (gdbscm_is_exception (result))
659 gdbscm_throw (result);
664 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
667 gdbscm_value_cast (SCM self, SCM new_type)
669 return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
672 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
675 gdbscm_value_dynamic_cast (SCM self, SCM new_type)
677 return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
680 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
683 gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
685 return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
688 /* (value-field <gdb:value> string) -> <gdb:value>
689 Given string name of an element inside structure, return its <gdb:value>
693 gdbscm_value_field (SCM self, SCM field_scm)
696 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
697 struct value *value = v_smob->value;
699 struct value *res_val = NULL;
701 struct cleanup *cleanups;
702 volatile struct gdb_exception except;
704 SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
707 cleanups = make_cleanup_value_free_to_mark (value_mark ());
709 field = gdbscm_scm_to_c_string (field_scm);
710 make_cleanup (xfree, field);
712 TRY_CATCH (except, RETURN_MASK_ALL)
714 struct value *tmp = value;
716 res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
718 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
720 gdb_assert (res_val != NULL);
721 result = vlscm_scm_from_value (res_val);
723 do_cleanups (cleanups);
725 if (gdbscm_is_exception (result))
726 gdbscm_throw (result);
731 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
732 Return the specified value in an array. */
735 gdbscm_value_subscript (SCM self, SCM index_scm)
738 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
739 struct value *value = v_smob->value;
740 struct value *index = NULL;
741 struct value *res_val = NULL;
742 struct type *type = value_type (value);
743 struct gdbarch *gdbarch;
744 SCM result, except_scm;
745 struct cleanup *cleanups;
746 volatile struct gdb_exception except;
748 /* The sequencing here, as everywhere else, is important.
749 We can't have existing cleanups when a Scheme exception is thrown. */
751 SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
752 gdbarch = get_type_arch (type);
754 cleanups = make_cleanup_value_free_to_mark (value_mark ());
756 index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
758 gdbarch, current_language);
761 do_cleanups (cleanups);
762 gdbscm_throw (except_scm);
765 TRY_CATCH (except, RETURN_MASK_ALL)
767 struct value *tmp = value;
769 /* Assume we are attempting an array access, and let the value code
770 throw an exception if the index has an invalid type.
771 Check the value's type is something that can be accessed via
773 tmp = coerce_ref (tmp);
774 type = check_typedef (value_type (tmp));
775 if (TYPE_CODE (type) != TYPE_CODE_ARRAY
776 && TYPE_CODE (type) != TYPE_CODE_PTR)
777 error (_("Cannot subscript requested type"));
779 res_val = value_subscript (tmp, value_as_long (index));
781 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
783 gdb_assert (res_val != NULL);
784 result = vlscm_scm_from_value (res_val);
786 do_cleanups (cleanups);
788 if (gdbscm_is_exception (result))
789 gdbscm_throw (result);
794 /* (value-call <gdb:value> arg-list) -> <gdb:value>
795 Perform an inferior function call on the value. */
798 gdbscm_value_call (SCM self, SCM args)
801 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
802 struct value *function = v_smob->value;
803 struct value *mark = value_mark ();
804 struct type *ftype = NULL;
806 struct value **vargs = NULL;
807 SCM result = SCM_BOOL_F;
808 volatile struct gdb_exception except;
810 TRY_CATCH (except, RETURN_MASK_ALL)
812 ftype = check_typedef (value_type (function));
814 GDBSCM_HANDLE_GDB_EXCEPTION (except);
816 SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
818 _("function (value of TYPE_CODE_FUNC)"));
820 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
821 SCM_ARG2, FUNC_NAME, _("list"));
823 args_count = scm_ilength (args);
826 struct gdbarch *gdbarch = get_current_arch ();
827 const struct language_defn *language = current_language;
831 vargs = alloca (sizeof (struct value *) * args_count);
832 for (i = 0; i < args_count; i++)
834 SCM arg = scm_car (args);
836 vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
837 GDBSCM_ARG_NONE, arg,
840 if (vargs[i] == NULL)
841 gdbscm_throw (except_scm);
843 args = scm_cdr (args);
845 gdb_assert (gdbscm_is_true (scm_null_p (args)));
848 TRY_CATCH (except, RETURN_MASK_ALL)
850 struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
851 struct value *return_value;
853 return_value = call_function_by_hand (function, args_count, vargs);
854 result = vlscm_scm_from_value (return_value);
855 do_cleanups (cleanup);
857 GDBSCM_HANDLE_GDB_EXCEPTION (except);
859 if (gdbscm_is_exception (result))
860 gdbscm_throw (result);
865 /* (value->bytevector <gdb:value>) -> bytevector */
868 gdbscm_value_to_bytevector (SCM self)
871 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
872 struct value *value = v_smob->value;
875 const gdb_byte *contents = NULL;
877 volatile struct gdb_exception except;
879 type = value_type (value);
881 TRY_CATCH (except, RETURN_MASK_ALL)
883 CHECK_TYPEDEF (type);
884 length = TYPE_LENGTH (type);
885 contents = value_contents (value);
887 GDBSCM_HANDLE_GDB_EXCEPTION (except);
889 bv = scm_c_make_bytevector (length);
890 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
895 /* Helper function to determine if a type is "int-like". */
898 is_intlike (struct type *type, int ptr_ok)
900 return (TYPE_CODE (type) == TYPE_CODE_INT
901 || TYPE_CODE (type) == TYPE_CODE_ENUM
902 || TYPE_CODE (type) == TYPE_CODE_BOOL
903 || TYPE_CODE (type) == TYPE_CODE_CHAR
904 || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
907 /* (value->bool <gdb:value>) -> boolean
908 Throws an error if the value is not integer-like. */
911 gdbscm_value_to_bool (SCM self)
914 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
915 struct value *value = v_smob->value;
918 volatile struct gdb_exception except;
920 type = value_type (value);
922 TRY_CATCH (except, RETURN_MASK_ALL)
924 CHECK_TYPEDEF (type);
926 GDBSCM_HANDLE_GDB_EXCEPTION (except);
928 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
929 _("integer-like gdb value"));
931 TRY_CATCH (except, RETURN_MASK_ALL)
933 if (TYPE_CODE (type) == TYPE_CODE_PTR)
934 l = value_as_address (value);
936 l = value_as_long (value);
938 GDBSCM_HANDLE_GDB_EXCEPTION (except);
940 return scm_from_bool (l != 0);
943 /* (value->integer <gdb:value>) -> integer
944 Throws an error if the value is not integer-like. */
947 gdbscm_value_to_integer (SCM self)
950 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
951 struct value *value = v_smob->value;
954 volatile struct gdb_exception except;
956 type = value_type (value);
958 TRY_CATCH (except, RETURN_MASK_ALL)
960 CHECK_TYPEDEF (type);
962 GDBSCM_HANDLE_GDB_EXCEPTION (except);
964 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
965 _("integer-like gdb value"));
967 TRY_CATCH (except, RETURN_MASK_ALL)
969 if (TYPE_CODE (type) == TYPE_CODE_PTR)
970 l = value_as_address (value);
972 l = value_as_long (value);
974 GDBSCM_HANDLE_GDB_EXCEPTION (except);
976 if (TYPE_UNSIGNED (type))
977 return gdbscm_scm_from_ulongest (l);
979 return gdbscm_scm_from_longest (l);
982 /* (value->real <gdb:value>) -> real
983 Throws an error if the value is not a number. */
986 gdbscm_value_to_real (SCM self)
989 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
990 struct value *value = v_smob->value;
993 volatile struct gdb_exception except;
995 type = value_type (value);
997 TRY_CATCH (except, RETURN_MASK_ALL)
999 CHECK_TYPEDEF (type);
1001 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1003 SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
1004 self, SCM_ARG1, FUNC_NAME, _("number"));
1006 TRY_CATCH (except, RETURN_MASK_ALL)
1008 d = value_as_double (value);
1010 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1012 /* TODO: Is there a better way to check if the value fits? */
1013 if (d != (double) d)
1014 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1015 _("number can't be converted to a double"));
1017 return scm_from_double (d);
1020 /* (value->string <gdb:value>
1021 [#:encoding encoding]
1022 [#:errors #f | 'error | 'substitute]
1025 Return Unicode string with value's contents, which must be a string.
1027 If ENCODING is not given, the string is assumed to be encoded in
1028 the target's charset.
1030 ERRORS is one of #f, 'error or 'substitute.
1031 An error setting of #f means use the default, which is
1032 Guile's %default-port-conversion-strategy. If the default is not one
1033 of 'error or 'substitute, 'substitute is used.
1034 An error setting of "error" causes an exception to be thrown if there's
1035 a decoding error. An error setting of "substitute" causes invalid
1036 characters to be replaced with "?".
1038 If LENGTH is provided, only fetch string to the length provided.
1039 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1042 gdbscm_value_to_string (SCM self, SCM rest)
1045 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1046 struct value *value = v_smob->value;
1047 const SCM keywords[] = {
1048 encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
1050 int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
1051 char *encoding = NULL;
1052 SCM errors = SCM_BOOL_F;
1054 gdb_byte *buffer = NULL;
1055 const char *la_encoding = NULL;
1056 struct type *char_type = NULL;
1058 struct cleanup *cleanups;
1059 volatile struct gdb_exception except;
1061 /* The sequencing here, as everywhere else, is important.
1062 We can't have existing cleanups when a Scheme exception is thrown. */
1064 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
1065 &encoding_arg_pos, &encoding,
1066 &errors_arg_pos, &errors,
1067 &length_arg_pos, &length);
1069 cleanups = make_cleanup (xfree, encoding);
1071 if (errors_arg_pos > 0
1072 && errors != SCM_BOOL_F
1073 && !scm_is_eq (errors, error_symbol)
1074 && !scm_is_eq (errors, substitute_symbol))
1077 = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
1078 _("invalid error kind"));
1080 do_cleanups (cleanups);
1081 gdbscm_throw (excp);
1083 if (errors == SCM_BOOL_F)
1084 errors = scm_port_conversion_strategy (SCM_BOOL_F);
1085 /* We don't assume anything about the result of scm_port_conversion_strategy.
1086 From this point on, if errors is not 'errors, use 'substitute. */
1088 TRY_CATCH (except, RETURN_MASK_ALL)
1090 LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
1092 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1094 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1095 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1096 discard_cleanups (cleanups);
1098 scm_dynwind_begin (0);
1100 gdbscm_dynwind_xfree (encoding);
1101 gdbscm_dynwind_xfree (buffer);
1103 result = scm_from_stringn ((const char *) buffer,
1104 length * TYPE_LENGTH (char_type),
1105 (encoding != NULL && *encoding != '\0'
1108 scm_is_eq (errors, error_symbol)
1109 ? SCM_FAILED_CONVERSION_ERROR
1110 : SCM_FAILED_CONVERSION_QUESTION_MARK);
1117 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1118 -> <gdb:lazy-string>
1119 Return a Scheme object representing a lazy_string_object type.
1120 A lazy string is a pointer to a string with an optional encoding and length.
1121 If ENCODING is not given, the target's charset is used.
1122 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1123 length will be set to -1 (first null of appropriate with).
1124 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1127 gdbscm_value_to_lazy_string (SCM self, SCM rest)
1130 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1131 struct value *value = v_smob->value;
1132 const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
1133 int encoding_arg_pos = -1, length_arg_pos = -1;
1134 char *encoding = NULL;
1136 SCM result = SCM_BOOL_F; /* -Wall */
1137 struct cleanup *cleanups;
1138 volatile struct gdb_exception except;
1140 /* The sequencing here, as everywhere else, is important.
1141 We can't have existing cleanups when a Scheme exception is thrown. */
1143 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
1144 &encoding_arg_pos, &encoding,
1145 &length_arg_pos, &length);
1147 cleanups = make_cleanup (xfree, encoding);
1149 TRY_CATCH (except, RETURN_MASK_ALL)
1151 struct cleanup *inner_cleanup
1152 = make_cleanup_value_free_to_mark (value_mark ());
1154 if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
1155 value = value_ind (value);
1157 result = lsscm_make_lazy_string (value_address (value), length,
1158 encoding, value_type (value));
1160 do_cleanups (inner_cleanup);
1162 do_cleanups (cleanups);
1163 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1165 if (gdbscm_is_exception (result))
1166 gdbscm_throw (result);
1171 /* (value-lazy? <gdb:value>) -> boolean */
1174 gdbscm_value_lazy_p (SCM self)
1177 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1178 struct value *value = v_smob->value;
1180 return scm_from_bool (value_lazy (value));
1183 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1186 gdbscm_value_fetch_lazy_x (SCM self)
1189 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1190 struct value *value = v_smob->value;
1191 volatile struct gdb_exception except;
1193 TRY_CATCH (except, RETURN_MASK_ALL)
1195 if (value_lazy (value))
1196 value_fetch_lazy (value);
1198 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1200 return SCM_UNSPECIFIED;
1203 /* (value-print <gdb:value>) -> string */
1206 gdbscm_value_print (SCM self)
1209 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1210 struct value *value = v_smob->value;
1211 struct value_print_options opts;
1214 volatile struct gdb_exception except;
1216 get_user_print_options (&opts);
1219 TRY_CATCH (except, RETURN_MASK_ALL)
1221 struct ui_file *stb = mem_fileopen ();
1222 struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
1224 common_val_print (value, stb, 0, &opts, current_language);
1225 s = ui_file_xstrdup (stb, NULL);
1227 do_cleanups (old_chain);
1229 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1231 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1232 throw an error if the encoding fails.
1233 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1234 override the default port conversion handler because contrary to
1235 documentation it doesn't necessarily free the input string. */
1236 result = scm_from_stringn (s, strlen (s), host_charset (),
1237 SCM_FAILED_CONVERSION_QUESTION_MARK);
1243 /* (parse-and-eval string) -> <gdb:value>
1244 Parse a string and evaluate the string as an expression. */
1247 gdbscm_parse_and_eval (SCM expr_scm)
1250 struct value *res_val = NULL;
1252 struct cleanup *cleanups;
1253 volatile struct gdb_exception except;
1255 /* The sequencing here, as everywhere else, is important.
1256 We can't have existing cleanups when a Scheme exception is thrown. */
1258 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
1259 expr_scm, &expr_str);
1261 cleanups = make_cleanup_value_free_to_mark (value_mark ());
1262 make_cleanup (xfree, expr_str);
1264 TRY_CATCH (except, RETURN_MASK_ALL)
1266 res_val = parse_and_eval (expr_str);
1268 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1270 gdb_assert (res_val != NULL);
1271 result = vlscm_scm_from_value (res_val);
1273 do_cleanups (cleanups);
1275 if (gdbscm_is_exception (result))
1276 gdbscm_throw (result);
1281 /* (history-ref integer) -> <gdb:value>
1282 Return the specified value from GDB's value history. */
1285 gdbscm_history_ref (SCM index)
1288 struct value *res_val = NULL; /* Initialize to appease gcc warning. */
1289 volatile struct gdb_exception except;
1291 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
1293 TRY_CATCH (except, RETURN_MASK_ALL)
1295 res_val = access_value_history (i);
1297 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1299 return vlscm_scm_from_value (res_val);
1302 /* (history-append! <gdb:value>) -> index
1303 Append VALUE to GDB's value history. Return its index in the history. */
1306 gdbscm_history_append_x (SCM value)
1310 volatile struct gdb_exception except;
1312 v = vlscm_scm_to_value (value);
1314 TRY_CATCH (except, RETURN_MASK_ALL)
1316 res_index = record_latest_value (v);
1318 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1320 return scm_from_int (res_index);
1323 /* Initialize the Scheme value code. */
1325 static const scheme_function value_functions[] =
1327 { "value?", 1, 0, 0, gdbscm_value_p,
1329 Return #t if the object is a <gdb:value> object." },
1331 { "make-value", 1, 0, 1, gdbscm_make_value,
1333 Create a <gdb:value> representing object.\n\
1334 Typically this is used to convert numbers and strings to\n\
1335 <gdb:value> objects.\n\
1337 Arguments: object [#:type <gdb:type>]" },
1339 { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
1341 Return #t if the value has been optimizd out." },
1343 { "value-address", 1, 0, 0, gdbscm_value_address,
1345 Return the address of the value." },
1347 { "value-type", 1, 0, 0, gdbscm_value_type,
1349 Return the type of the value." },
1351 { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
1353 Return the dynamic type of the value." },
1355 { "value-cast", 2, 0, 0, gdbscm_value_cast,
1357 Cast the value to the supplied type.\n\
1359 Arguments: <gdb:value> <gdb:type>" },
1361 { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
1363 Cast the value to the supplied type, as if by the C++\n\
1364 dynamic_cast operator.\n\
1366 Arguments: <gdb:value> <gdb:type>" },
1368 { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
1370 Cast the value to the supplied type, as if by the C++\n\
1371 reinterpret_cast operator.\n\
1373 Arguments: <gdb:value> <gdb:type>" },
1375 { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
1377 Return the result of applying the C unary * operator to the value." },
1379 { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
1381 Given a value of a reference type, return the value referenced.\n\
1382 The difference between this function and value-dereference is that\n\
1383 the latter applies * unary operator to a value, which need not always\n\
1384 result in the value referenced.\n\
1385 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1386 value-dereference will result in a value of type 'int' while\n\
1387 value-referenced-value will result in a value of type 'int *'." },
1389 { "value-field", 2, 0, 0, gdbscm_value_field,
1391 Return the specified field of the value.\n\
1393 Arguments: <gdb:value> string" },
1395 { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
1397 Return the value of the array at the specified index.\n\
1399 Arguments: <gdb:value> integer" },
1401 { "value-call", 2, 0, 0, gdbscm_value_call,
1403 Perform an inferior function call taking the value as a pointer to the\n\
1404 function to call.\n\
1405 Each element of the argument list must be a <gdb:value> object or an object\n\
1406 that can be converted to one.\n\
1407 The result is the value returned by the function.\n\
1409 Arguments: <gdb:value> arg-list" },
1411 { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
1413 Return the Scheme boolean representing the GDB value.\n\
1414 The value must be \"integer like\". Pointers are ok." },
1416 { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
1418 Return the Scheme integer representing the GDB value.\n\
1419 The value must be \"integer like\". Pointers are ok." },
1421 { "value->real", 1, 0, 0, gdbscm_value_to_real,
1423 Return the Scheme real number representing the GDB value.\n\
1424 The value must be a number." },
1426 { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
1428 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1429 No transformation, endian or otherwise, is performed." },
1431 { "value->string", 1, 0, 1, gdbscm_value_to_string,
1433 Return the Unicode string of the value's contents.\n\
1434 If ENCODING is not given, the string is assumed to be encoded in\n\
1435 the target's charset.\n\
1436 An error setting \"error\" causes an exception to be thrown if there's\n\
1437 a decoding error. An error setting of \"substitute\" causes invalid\n\
1438 characters to be replaced with \"?\". The default is \"error\".\n\
1439 If LENGTH is provided, only fetch string to the length provided.\n\
1441 Arguments: <gdb:value>\n\
1442 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1443 [#:length length]" },
1445 { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
1447 Return a Scheme object representing a lazily fetched Unicode string\n\
1448 of the value's contents.\n\
1449 If ENCODING is not given, the string is assumed to be encoded in\n\
1450 the target's charset.\n\
1451 If LENGTH is provided, only fetch string to the length provided.\n\
1453 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1455 { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
1457 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1458 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1461 { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
1463 Create a <gdb:value> that will be lazily fetched from the target.\n\
1465 Arguments: <gdb:type> address" },
1467 { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
1469 Fetch the value from the inferior, if it was lazy.\n\
1470 The result is \"unspecified\"." },
1472 { "value-print", 1, 0, 0, gdbscm_value_print,
1474 Return the string representation (print form) of the value." },
1476 { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
1478 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1480 { "history-ref", 1, 0, 0, gdbscm_history_ref,
1482 Return the specified value from GDB's value history." },
1484 { "history-append!", 1, 0, 0, gdbscm_history_append_x,
1486 Append the specified value onto GDB's value history." },
1492 gdbscm_initialize_values (void)
1494 value_smob_tag = gdbscm_make_smob_type (value_smob_name,
1495 sizeof (value_smob));
1496 scm_set_smob_mark (value_smob_tag, vlscm_mark_value_smob);
1497 scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
1498 scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
1499 scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
1501 gdbscm_define_functions (value_functions, 1);
1503 type_keyword = scm_from_latin1_keyword ("type");
1504 encoding_keyword = scm_from_latin1_keyword ("encoding");
1505 errors_keyword = scm_from_latin1_keyword ("errors");
1506 length_keyword = scm_from_latin1_keyword ("length");
1508 error_symbol = scm_from_latin1_symbol ("error");
1509 escape_symbol = scm_from_latin1_symbol ("escape");
1510 substitute_symbol = scm_from_latin1_symbol ("substitute");