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"
28 #include "symtab.h" /* Needed by language.h. */
32 #include "guile-internal.h"
34 /* The <gdb:value> smob. */
36 typedef struct _value_smob
38 /* This always appears first. */
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;
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. */
59 static const char value_smob_name[] = "gdb:value";
61 /* The tag Guile knows the value smob by. */
62 static scm_t_bits value_smob_tag;
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;
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;
75 /* Possible #:errors values. */
76 static SCM error_symbol;
77 static SCM escape_symbol;
78 static SCM substitute_symbol;
80 /* Administrivia for value smobs. */
82 /* Iterate over all the <gdb:value> objects, calling preserve_one_value on
84 This is the extension_language_ops.preserve_values "method". */
87 gdbscm_preserve_values (const struct extension_language_defn *extlang,
88 struct objfile *objfile, htab_t copied_types)
92 for (iter = values_in_scheme; iter; iter = iter->next)
93 preserve_one_value (iter->value, objfile, copied_types);
96 /* Helper to add a value_smob to the global list. */
99 vlscm_remember_scheme_value (value_smob *v_smob)
101 v_smob->next = values_in_scheme;
103 v_smob->next->prev = v_smob;
105 values_in_scheme = v_smob;
108 /* Helper to remove a value_smob from the global list. */
111 vlscm_forget_value_smob (value_smob *v_smob)
113 /* Remove SELF from the global list. */
115 v_smob->prev->next = v_smob->next;
118 gdb_assert (values_in_scheme == v_smob);
119 values_in_scheme = v_smob->next;
122 v_smob->next->prev = v_smob->prev;
125 /* The smob "free" function for <gdb:value>. */
128 vlscm_free_value_smob (SCM self)
130 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
132 vlscm_forget_value_smob (v_smob);
133 value_free (v_smob->value);
138 /* The smob "print" function for <gdb:value>. */
141 vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
143 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
145 struct value_print_options opts;
146 volatile struct gdb_exception except;
148 if (pstate->writingp)
149 gdbscm_printf (port, "#<%s ", value_smob_name);
151 get_user_print_options (&opts);
154 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
155 invoked by write/~S. What to do here may need to evolve.
156 IWBN if we could pass an argument to format that would we could use
157 instead of writingp. */
158 opts.raw = !!pstate->writingp;
160 TRY_CATCH (except, RETURN_MASK_ALL)
162 struct ui_file *stb = mem_fileopen ();
163 struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
165 common_val_print (v_smob->value, stb, 0, &opts, current_language);
166 s = ui_file_xstrdup (stb, NULL);
168 do_cleanups (old_chain);
170 GDBSCM_HANDLE_GDB_EXCEPTION (except);
178 if (pstate->writingp)
179 scm_puts (">", port);
181 scm_remember_upto_here_1 (self);
183 /* Non-zero means success. */
187 /* The smob "equalp" function for <gdb:value>. */
190 vlscm_equal_p_value_smob (SCM v1, SCM v2)
192 const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
193 const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
195 volatile struct gdb_exception except;
197 TRY_CATCH (except, RETURN_MASK_ALL)
199 result = value_equal (v1_smob->value, v2_smob->value);
201 GDBSCM_HANDLE_GDB_EXCEPTION (except);
203 return scm_from_bool (result);
206 /* Low level routine to create a <gdb:value> object. */
209 vlscm_make_value_smob (void)
211 value_smob *v_smob = (value_smob *)
212 scm_gc_malloc (sizeof (value_smob), value_smob_name);
215 /* These must be filled in by the caller. */
216 v_smob->value = NULL;
220 /* These are lazily computed. */
221 v_smob->address = SCM_UNDEFINED;
222 v_smob->type = SCM_UNDEFINED;
223 v_smob->dynamic_type = SCM_UNDEFINED;
225 v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
226 gdbscm_init_gsmob (&v_smob->base);
231 /* Return non-zero if SCM is a <gdb:value> object. */
234 vlscm_is_value (SCM scm)
236 return SCM_SMOB_PREDICATE (value_smob_tag, scm);
239 /* (value? object) -> boolean */
242 gdbscm_value_p (SCM scm)
244 return scm_from_bool (vlscm_is_value (scm));
247 /* Create a new <gdb:value> object that encapsulates VALUE.
248 The value is released from the all_values chain so its lifetime is not
249 bound to the execution of a command. */
252 vlscm_scm_from_value (struct value *value)
254 /* N.B. It's important to not cause any side-effects until we know the
255 conversion worked. */
256 SCM v_scm = vlscm_make_value_smob ();
257 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
259 v_smob->value = value;
260 release_value_or_incref (value);
261 vlscm_remember_scheme_value (v_smob);
266 /* Returns the <gdb:value> object in SELF.
267 Throws an exception if SELF is not a <gdb:value> object. */
270 vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
272 SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
278 /* Returns a pointer to the value smob of SELF.
279 Throws an exception if SELF is not a <gdb:value> object. */
282 vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
284 SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
285 value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
290 /* Return the value field of V_SCM, an object of type <gdb:value>.
291 This exists so that we don't have to export the struct's contents. */
294 vlscm_scm_to_value (SCM v_scm)
298 gdb_assert (vlscm_is_value (v_scm));
299 v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
300 return v_smob->value;
305 /* (make-value x [#:type type]) -> <gdb:value> */
308 gdbscm_make_value (SCM x, SCM rest)
310 struct gdbarch *gdbarch = get_current_arch ();
311 const struct language_defn *language = current_language;
312 const SCM keywords[] = { type_keyword, SCM_BOOL_F };
313 int type_arg_pos = -1;
314 SCM type_scm = SCM_UNDEFINED;
315 SCM except_scm, result;
317 struct type *type = NULL;
319 struct cleanup *cleanups;
321 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
322 &type_arg_pos, &type_scm);
324 if (type_arg_pos > 0)
326 t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
328 type = tyscm_type_smob_type (t_smob);
331 cleanups = make_cleanup_value_free_to_mark (value_mark ());
333 value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
334 type_arg_pos, type_scm, type,
339 do_cleanups (cleanups);
340 gdbscm_throw (except_scm);
343 result = vlscm_scm_from_value (value);
345 do_cleanups (cleanups);
347 if (gdbscm_is_exception (result))
348 gdbscm_throw (result);
352 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
355 gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
360 struct value *value = NULL;
362 struct cleanup *cleanups;
363 volatile struct gdb_exception except;
365 t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
366 type = tyscm_type_smob_type (t_smob);
368 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
369 address_scm, &address);
371 cleanups = make_cleanup_value_free_to_mark (value_mark ());
373 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
374 and future-proofing we do. */
375 TRY_CATCH (except, RETURN_MASK_ALL)
377 value = value_from_contents_and_address (type, NULL, address);
379 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
381 result = vlscm_scm_from_value (value);
383 do_cleanups (cleanups);
385 if (gdbscm_is_exception (result))
386 gdbscm_throw (result);
390 /* (value-optimized-out? <gdb:value>) -> boolean */
393 gdbscm_value_optimized_out_p (SCM self)
396 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
397 struct value *value = v_smob->value;
399 volatile struct gdb_exception except;
401 TRY_CATCH (except, RETURN_MASK_ALL)
403 opt = value_optimized_out (value);
405 GDBSCM_HANDLE_GDB_EXCEPTION (except);
407 return scm_from_bool (opt);
410 /* (value-address <gdb:value>) -> integer
411 Returns #f if the value doesn't have one. */
414 gdbscm_value_address (SCM self)
417 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
418 struct value *value = v_smob->value;
420 if (SCM_UNBNDP (v_smob->address))
422 struct value *res_val = NULL;
423 struct cleanup *cleanup
424 = make_cleanup_value_free_to_mark (value_mark ());
426 volatile struct gdb_exception except;
428 TRY_CATCH (except, RETURN_MASK_ALL)
430 res_val = value_addr (value);
432 if (except.reason < 0)
433 address = SCM_BOOL_F;
435 address = vlscm_scm_from_value (res_val);
437 do_cleanups (cleanup);
439 if (gdbscm_is_exception (address))
440 gdbscm_throw (address);
442 v_smob->address = address;
445 return v_smob->address;
448 /* (value-dereference <gdb:value>) -> <gdb:value>
449 Given a value of a pointer type, apply the C unary * operator to it. */
452 gdbscm_value_dereference (SCM self)
455 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
456 struct value *value = v_smob->value;
458 struct value *res_val = NULL;
459 struct cleanup *cleanups;
460 volatile struct gdb_exception except;
462 cleanups = make_cleanup_value_free_to_mark (value_mark ());
464 TRY_CATCH (except, RETURN_MASK_ALL)
466 res_val = value_ind (value);
468 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
470 result = vlscm_scm_from_value (res_val);
472 do_cleanups (cleanups);
474 if (gdbscm_is_exception (result))
475 gdbscm_throw (result);
480 /* (value-referenced-value <gdb:value>) -> <gdb:value>
481 Given a value of a reference type, return the value referenced.
482 The difference between this function and gdbscm_value_dereference is that
483 the latter applies * unary operator to a value, which need not always
484 result in the value referenced.
485 For example, for a value which is a reference to an 'int' pointer ('int *'),
486 gdbscm_value_dereference will result in a value of type 'int' while
487 gdbscm_value_referenced_value will result in a value of type 'int *'. */
490 gdbscm_value_referenced_value (SCM self)
493 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
494 struct value *value = v_smob->value;
496 struct value *res_val = NULL;
497 struct cleanup *cleanups;
498 volatile struct gdb_exception except;
500 cleanups = make_cleanup_value_free_to_mark (value_mark ());
502 TRY_CATCH (except, RETURN_MASK_ALL)
504 switch (TYPE_CODE (check_typedef (value_type (value))))
507 res_val = value_ind (value);
510 res_val = coerce_ref (value);
513 error (_("Trying to get the referenced value from a value which is"
514 " neither a pointer nor a reference"));
517 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
519 result = vlscm_scm_from_value (res_val);
521 do_cleanups (cleanups);
523 if (gdbscm_is_exception (result))
524 gdbscm_throw (result);
529 /* (value-type <gdb:value>) -> <gdb:type> */
532 gdbscm_value_type (SCM self)
535 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
536 struct value *value = v_smob->value;
538 if (SCM_UNBNDP (v_smob->type))
539 v_smob->type = tyscm_scm_from_type (value_type (value));
544 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
547 gdbscm_value_dynamic_type (SCM self)
550 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
551 struct value *value = v_smob->value;
552 struct type *type = NULL;
553 volatile struct gdb_exception except;
555 if (! SCM_UNBNDP (v_smob->type))
556 return v_smob->dynamic_type;
558 TRY_CATCH (except, RETURN_MASK_ALL)
560 struct cleanup *cleanup
561 = make_cleanup_value_free_to_mark (value_mark ());
563 type = value_type (value);
564 CHECK_TYPEDEF (type);
566 if (((TYPE_CODE (type) == TYPE_CODE_PTR)
567 || (TYPE_CODE (type) == TYPE_CODE_REF))
568 && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRUCT))
570 struct value *target;
571 int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
574 target = value_ind (value);
576 target = coerce_ref (value);
577 type = value_rtti_type (target, NULL, NULL, NULL);
582 type = lookup_pointer_type (type);
584 type = lookup_reference_type (type);
587 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
588 type = value_rtti_type (value, NULL, NULL, NULL);
591 /* Re-use object's static type. */
595 do_cleanups (cleanup);
597 GDBSCM_HANDLE_GDB_EXCEPTION (except);
600 v_smob->dynamic_type = gdbscm_value_type (self);
602 v_smob->dynamic_type = tyscm_scm_from_type (type);
604 return v_smob->dynamic_type;
607 /* A helper function that implements the various cast operators. */
610 vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
611 const char *func_name)
614 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
615 struct value *value = v_smob->value;
617 = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
618 struct type *type = tyscm_type_smob_type (t_smob);
620 struct value *res_val = NULL;
621 struct cleanup *cleanups;
622 volatile struct gdb_exception except;
624 cleanups = make_cleanup_value_free_to_mark (value_mark ());
626 TRY_CATCH (except, RETURN_MASK_ALL)
628 if (op == UNOP_DYNAMIC_CAST)
629 res_val = value_dynamic_cast (type, value);
630 else if (op == UNOP_REINTERPRET_CAST)
631 res_val = value_reinterpret_cast (type, value);
634 gdb_assert (op == UNOP_CAST);
635 res_val = value_cast (type, value);
638 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
640 gdb_assert (res_val != NULL);
641 result = vlscm_scm_from_value (res_val);
643 do_cleanups (cleanups);
645 if (gdbscm_is_exception (result))
646 gdbscm_throw (result);
651 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
654 gdbscm_value_cast (SCM self, SCM new_type)
656 return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
659 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
662 gdbscm_value_dynamic_cast (SCM self, SCM new_type)
664 return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
667 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
670 gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
672 return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
675 /* (value-field <gdb:value> string) -> <gdb:value>
676 Given string name of an element inside structure, return its <gdb:value>
680 gdbscm_value_field (SCM self, SCM field_scm)
683 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
684 struct value *value = v_smob->value;
686 struct value *res_val = NULL;
688 struct cleanup *cleanups;
689 volatile struct gdb_exception except;
691 SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
694 cleanups = make_cleanup_value_free_to_mark (value_mark ());
696 field = gdbscm_scm_to_c_string (field_scm);
697 make_cleanup (xfree, field);
699 TRY_CATCH (except, RETURN_MASK_ALL)
701 struct value *tmp = value;
703 res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
705 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
707 gdb_assert (res_val != NULL);
708 result = vlscm_scm_from_value (res_val);
710 do_cleanups (cleanups);
712 if (gdbscm_is_exception (result))
713 gdbscm_throw (result);
718 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
719 Return the specified value in an array. */
722 gdbscm_value_subscript (SCM self, SCM index_scm)
725 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
726 struct value *value = v_smob->value;
727 struct value *index = NULL;
728 struct value *res_val = NULL;
729 struct type *type = value_type (value);
730 struct gdbarch *gdbarch;
731 SCM result, except_scm;
732 struct cleanup *cleanups;
733 volatile struct gdb_exception except;
735 /* The sequencing here, as everywhere else, is important.
736 We can't have existing cleanups when a Scheme exception is thrown. */
738 SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
739 gdbarch = get_type_arch (type);
741 cleanups = make_cleanup_value_free_to_mark (value_mark ());
743 index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
745 gdbarch, current_language);
748 do_cleanups (cleanups);
749 gdbscm_throw (except_scm);
752 TRY_CATCH (except, RETURN_MASK_ALL)
754 struct value *tmp = value;
756 /* Assume we are attempting an array access, and let the value code
757 throw an exception if the index has an invalid type.
758 Check the value's type is something that can be accessed via
760 tmp = coerce_ref (tmp);
761 type = check_typedef (value_type (tmp));
762 if (TYPE_CODE (type) != TYPE_CODE_ARRAY
763 && TYPE_CODE (type) != TYPE_CODE_PTR)
764 error (_("Cannot subscript requested type"));
766 res_val = value_subscript (tmp, value_as_long (index));
768 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
770 gdb_assert (res_val != NULL);
771 result = vlscm_scm_from_value (res_val);
773 do_cleanups (cleanups);
775 if (gdbscm_is_exception (result))
776 gdbscm_throw (result);
781 /* (value-call <gdb:value> arg-list) -> <gdb:value>
782 Perform an inferior function call on the value. */
785 gdbscm_value_call (SCM self, SCM args)
788 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
789 struct value *function = v_smob->value;
790 struct value *mark = value_mark ();
791 struct type *ftype = NULL;
793 struct value **vargs = NULL;
794 SCM result = SCM_BOOL_F;
795 volatile struct gdb_exception except;
797 TRY_CATCH (except, RETURN_MASK_ALL)
799 ftype = check_typedef (value_type (function));
801 GDBSCM_HANDLE_GDB_EXCEPTION (except);
803 SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
805 _("function (value of TYPE_CODE_FUNC)"));
807 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
808 SCM_ARG2, FUNC_NAME, _("list"));
810 args_count = scm_ilength (args);
813 struct gdbarch *gdbarch = get_current_arch ();
814 const struct language_defn *language = current_language;
818 vargs = alloca (sizeof (struct value *) * args_count);
819 for (i = 0; i < args_count; i++)
821 SCM arg = scm_car (args);
823 vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
824 GDBSCM_ARG_NONE, arg,
827 if (vargs[i] == NULL)
828 gdbscm_throw (except_scm);
830 args = scm_cdr (args);
832 gdb_assert (gdbscm_is_true (scm_null_p (args)));
835 TRY_CATCH (except, RETURN_MASK_ALL)
837 struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
838 struct value *return_value;
840 return_value = call_function_by_hand (function, args_count, vargs);
841 result = vlscm_scm_from_value (return_value);
842 do_cleanups (cleanup);
844 GDBSCM_HANDLE_GDB_EXCEPTION (except);
846 if (gdbscm_is_exception (result))
847 gdbscm_throw (result);
852 /* (value->bytevector <gdb:value>) -> bytevector */
855 gdbscm_value_to_bytevector (SCM self)
858 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
859 struct value *value = v_smob->value;
862 const gdb_byte *contents = NULL;
864 volatile struct gdb_exception except;
866 type = value_type (value);
868 TRY_CATCH (except, RETURN_MASK_ALL)
870 CHECK_TYPEDEF (type);
871 length = TYPE_LENGTH (type);
872 contents = value_contents (value);
874 GDBSCM_HANDLE_GDB_EXCEPTION (except);
876 bv = scm_c_make_bytevector (length);
877 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
882 /* Helper function to determine if a type is "int-like". */
885 is_intlike (struct type *type, int ptr_ok)
887 return (TYPE_CODE (type) == TYPE_CODE_INT
888 || TYPE_CODE (type) == TYPE_CODE_ENUM
889 || TYPE_CODE (type) == TYPE_CODE_BOOL
890 || TYPE_CODE (type) == TYPE_CODE_CHAR
891 || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
894 /* (value->bool <gdb:value>) -> boolean
895 Throws an error if the value is not integer-like. */
898 gdbscm_value_to_bool (SCM self)
901 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
902 struct value *value = v_smob->value;
905 volatile struct gdb_exception except;
907 type = value_type (value);
909 TRY_CATCH (except, RETURN_MASK_ALL)
911 CHECK_TYPEDEF (type);
913 GDBSCM_HANDLE_GDB_EXCEPTION (except);
915 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
916 _("integer-like gdb value"));
918 TRY_CATCH (except, RETURN_MASK_ALL)
920 if (TYPE_CODE (type) == TYPE_CODE_PTR)
921 l = value_as_address (value);
923 l = value_as_long (value);
925 GDBSCM_HANDLE_GDB_EXCEPTION (except);
927 return scm_from_bool (l != 0);
930 /* (value->integer <gdb:value>) -> integer
931 Throws an error if the value is not integer-like. */
934 gdbscm_value_to_integer (SCM self)
937 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
938 struct value *value = v_smob->value;
941 volatile struct gdb_exception except;
943 type = value_type (value);
945 TRY_CATCH (except, RETURN_MASK_ALL)
947 CHECK_TYPEDEF (type);
949 GDBSCM_HANDLE_GDB_EXCEPTION (except);
951 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
952 _("integer-like gdb value"));
954 TRY_CATCH (except, RETURN_MASK_ALL)
956 if (TYPE_CODE (type) == TYPE_CODE_PTR)
957 l = value_as_address (value);
959 l = value_as_long (value);
961 GDBSCM_HANDLE_GDB_EXCEPTION (except);
963 if (TYPE_UNSIGNED (type))
964 return gdbscm_scm_from_ulongest (l);
966 return gdbscm_scm_from_longest (l);
969 /* (value->real <gdb:value>) -> real
970 Throws an error if the value is not a number. */
973 gdbscm_value_to_real (SCM self)
976 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
977 struct value *value = v_smob->value;
980 volatile struct gdb_exception except;
982 type = value_type (value);
984 TRY_CATCH (except, RETURN_MASK_ALL)
986 CHECK_TYPEDEF (type);
988 GDBSCM_HANDLE_GDB_EXCEPTION (except);
990 SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
991 self, SCM_ARG1, FUNC_NAME, _("number"));
993 TRY_CATCH (except, RETURN_MASK_ALL)
995 d = value_as_double (value);
997 GDBSCM_HANDLE_GDB_EXCEPTION (except);
999 /* TODO: Is there a better way to check if the value fits? */
1000 if (d != (double) d)
1001 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1002 _("number can't be converted to a double"));
1004 return scm_from_double (d);
1007 /* (value->string <gdb:value>
1008 [#:encoding encoding]
1009 [#:errors #f | 'error | 'substitute]
1012 Return Unicode string with value's contents, which must be a string.
1014 If ENCODING is not given, the string is assumed to be encoded in
1015 the target's charset.
1017 ERRORS is one of #f, 'error or 'substitute.
1018 An error setting of #f means use the default, which is Guile's
1019 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1020 using an earlier version of Guile. Earlier versions do not properly
1021 support obtaining the default port conversion strategy.
1022 If the default is not one of 'error or 'substitute, 'substitute is used.
1023 An error setting of "error" causes an exception to be thrown if there's
1024 a decoding error. An error setting of "substitute" causes invalid
1025 characters to be replaced with "?".
1027 If LENGTH is provided, only fetch string to the length provided.
1028 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1031 gdbscm_value_to_string (SCM self, SCM rest)
1034 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1035 struct value *value = v_smob->value;
1036 const SCM keywords[] = {
1037 encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
1039 int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
1040 char *encoding = NULL;
1041 SCM errors = SCM_BOOL_F;
1043 gdb_byte *buffer = NULL;
1044 const char *la_encoding = NULL;
1045 struct type *char_type = NULL;
1047 struct cleanup *cleanups;
1048 volatile struct gdb_exception except;
1050 /* The sequencing here, as everywhere else, is important.
1051 We can't have existing cleanups when a Scheme exception is thrown. */
1053 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
1054 &encoding_arg_pos, &encoding,
1055 &errors_arg_pos, &errors,
1056 &length_arg_pos, &length);
1058 cleanups = make_cleanup (xfree, encoding);
1060 if (errors_arg_pos > 0
1061 && errors != SCM_BOOL_F
1062 && !scm_is_eq (errors, error_symbol)
1063 && !scm_is_eq (errors, substitute_symbol))
1066 = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
1067 _("invalid error kind"));
1069 do_cleanups (cleanups);
1070 gdbscm_throw (excp);
1072 if (errors == SCM_BOOL_F)
1074 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1075 will throw a Scheme error when passed #f. */
1076 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1077 errors = scm_port_conversion_strategy (SCM_BOOL_F);
1079 errors = error_symbol;
1081 /* We don't assume anything about the result of scm_port_conversion_strategy.
1082 From this point on, if errors is not 'errors, use 'substitute. */
1084 TRY_CATCH (except, RETURN_MASK_ALL)
1086 LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
1088 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1090 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1091 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1092 discard_cleanups (cleanups);
1094 scm_dynwind_begin (0);
1096 gdbscm_dynwind_xfree (encoding);
1097 gdbscm_dynwind_xfree (buffer);
1099 result = scm_from_stringn ((const char *) buffer,
1100 length * TYPE_LENGTH (char_type),
1101 (encoding != NULL && *encoding != '\0'
1104 scm_is_eq (errors, error_symbol)
1105 ? SCM_FAILED_CONVERSION_ERROR
1106 : SCM_FAILED_CONVERSION_QUESTION_MARK);
1113 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1114 -> <gdb:lazy-string>
1115 Return a Scheme object representing a lazy_string_object type.
1116 A lazy string is a pointer to a string with an optional encoding and length.
1117 If ENCODING is not given, the target's charset is used.
1118 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1119 length will be set to -1 (first null of appropriate with).
1120 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1123 gdbscm_value_to_lazy_string (SCM self, SCM rest)
1126 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1127 struct value *value = v_smob->value;
1128 const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
1129 int encoding_arg_pos = -1, length_arg_pos = -1;
1130 char *encoding = NULL;
1132 SCM result = SCM_BOOL_F; /* -Wall */
1133 struct cleanup *cleanups;
1134 volatile struct gdb_exception except;
1136 /* The sequencing here, as everywhere else, is important.
1137 We can't have existing cleanups when a Scheme exception is thrown. */
1139 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
1140 &encoding_arg_pos, &encoding,
1141 &length_arg_pos, &length);
1143 cleanups = make_cleanup (xfree, encoding);
1145 TRY_CATCH (except, RETURN_MASK_ALL)
1147 struct cleanup *inner_cleanup
1148 = make_cleanup_value_free_to_mark (value_mark ());
1150 if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
1151 value = value_ind (value);
1153 result = lsscm_make_lazy_string (value_address (value), length,
1154 encoding, value_type (value));
1156 do_cleanups (inner_cleanup);
1158 do_cleanups (cleanups);
1159 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1161 if (gdbscm_is_exception (result))
1162 gdbscm_throw (result);
1167 /* (value-lazy? <gdb:value>) -> boolean */
1170 gdbscm_value_lazy_p (SCM self)
1173 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1174 struct value *value = v_smob->value;
1176 return scm_from_bool (value_lazy (value));
1179 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1182 gdbscm_value_fetch_lazy_x (SCM self)
1185 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1186 struct value *value = v_smob->value;
1187 volatile struct gdb_exception except;
1189 TRY_CATCH (except, RETURN_MASK_ALL)
1191 if (value_lazy (value))
1192 value_fetch_lazy (value);
1194 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1196 return SCM_UNSPECIFIED;
1199 /* (value-print <gdb:value>) -> string */
1202 gdbscm_value_print (SCM self)
1205 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1206 struct value *value = v_smob->value;
1207 struct value_print_options opts;
1210 volatile struct gdb_exception except;
1212 get_user_print_options (&opts);
1215 TRY_CATCH (except, RETURN_MASK_ALL)
1217 struct ui_file *stb = mem_fileopen ();
1218 struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
1220 common_val_print (value, stb, 0, &opts, current_language);
1221 s = ui_file_xstrdup (stb, NULL);
1223 do_cleanups (old_chain);
1225 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1227 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1228 throw an error if the encoding fails.
1229 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1230 override the default port conversion handler because contrary to
1231 documentation it doesn't necessarily free the input string. */
1232 result = scm_from_stringn (s, strlen (s), host_charset (),
1233 SCM_FAILED_CONVERSION_QUESTION_MARK);
1239 /* (parse-and-eval string) -> <gdb:value>
1240 Parse a string and evaluate the string as an expression. */
1243 gdbscm_parse_and_eval (SCM expr_scm)
1246 struct value *res_val = NULL;
1248 struct cleanup *cleanups;
1249 volatile struct gdb_exception except;
1251 /* The sequencing here, as everywhere else, is important.
1252 We can't have existing cleanups when a Scheme exception is thrown. */
1254 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
1255 expr_scm, &expr_str);
1257 cleanups = make_cleanup_value_free_to_mark (value_mark ());
1258 make_cleanup (xfree, expr_str);
1260 TRY_CATCH (except, RETURN_MASK_ALL)
1262 res_val = parse_and_eval (expr_str);
1264 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1266 gdb_assert (res_val != NULL);
1267 result = vlscm_scm_from_value (res_val);
1269 do_cleanups (cleanups);
1271 if (gdbscm_is_exception (result))
1272 gdbscm_throw (result);
1277 /* (history-ref integer) -> <gdb:value>
1278 Return the specified value from GDB's value history. */
1281 gdbscm_history_ref (SCM index)
1284 struct value *res_val = NULL; /* Initialize to appease gcc warning. */
1285 volatile struct gdb_exception except;
1287 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
1289 TRY_CATCH (except, RETURN_MASK_ALL)
1291 res_val = access_value_history (i);
1293 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1295 return vlscm_scm_from_value (res_val);
1298 /* (history-append! <gdb:value>) -> index
1299 Append VALUE to GDB's value history. Return its index in the history. */
1302 gdbscm_history_append_x (SCM value)
1307 volatile struct gdb_exception except;
1309 v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
1312 TRY_CATCH (except, RETURN_MASK_ALL)
1314 res_index = record_latest_value (v);
1316 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1318 return scm_from_int (res_index);
1321 /* Initialize the Scheme value code. */
1323 static const scheme_function value_functions[] =
1325 { "value?", 1, 0, 0, gdbscm_value_p,
1327 Return #t if the object is a <gdb:value> object." },
1329 { "make-value", 1, 0, 1, gdbscm_make_value,
1331 Create a <gdb:value> representing object.\n\
1332 Typically this is used to convert numbers and strings to\n\
1333 <gdb:value> objects.\n\
1335 Arguments: object [#:type <gdb:type>]" },
1337 { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
1339 Return #t if the value has been optimizd out." },
1341 { "value-address", 1, 0, 0, gdbscm_value_address,
1343 Return the address of the value." },
1345 { "value-type", 1, 0, 0, gdbscm_value_type,
1347 Return the type of the value." },
1349 { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
1351 Return the dynamic type of the value." },
1353 { "value-cast", 2, 0, 0, gdbscm_value_cast,
1355 Cast the value to the supplied type.\n\
1357 Arguments: <gdb:value> <gdb:type>" },
1359 { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
1361 Cast the value to the supplied type, as if by the C++\n\
1362 dynamic_cast operator.\n\
1364 Arguments: <gdb:value> <gdb:type>" },
1366 { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
1368 Cast the value to the supplied type, as if by the C++\n\
1369 reinterpret_cast operator.\n\
1371 Arguments: <gdb:value> <gdb:type>" },
1373 { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
1375 Return the result of applying the C unary * operator to the value." },
1377 { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
1379 Given a value of a reference type, return the value referenced.\n\
1380 The difference between this function and value-dereference is that\n\
1381 the latter applies * unary operator to a value, which need not always\n\
1382 result in the value referenced.\n\
1383 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1384 value-dereference will result in a value of type 'int' while\n\
1385 value-referenced-value will result in a value of type 'int *'." },
1387 { "value-field", 2, 0, 0, gdbscm_value_field,
1389 Return the specified field of the value.\n\
1391 Arguments: <gdb:value> string" },
1393 { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
1395 Return the value of the array at the specified index.\n\
1397 Arguments: <gdb:value> integer" },
1399 { "value-call", 2, 0, 0, gdbscm_value_call,
1401 Perform an inferior function call taking the value as a pointer to the\n\
1402 function to call.\n\
1403 Each element of the argument list must be a <gdb:value> object or an object\n\
1404 that can be converted to one.\n\
1405 The result is the value returned by the function.\n\
1407 Arguments: <gdb:value> arg-list" },
1409 { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
1411 Return the Scheme boolean representing the GDB value.\n\
1412 The value must be \"integer like\". Pointers are ok." },
1414 { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
1416 Return the Scheme integer representing the GDB value.\n\
1417 The value must be \"integer like\". Pointers are ok." },
1419 { "value->real", 1, 0, 0, gdbscm_value_to_real,
1421 Return the Scheme real number representing the GDB value.\n\
1422 The value must be a number." },
1424 { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
1426 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1427 No transformation, endian or otherwise, is performed." },
1429 { "value->string", 1, 0, 1, gdbscm_value_to_string,
1431 Return the Unicode string of the value's contents.\n\
1432 If ENCODING is not given, the string is assumed to be encoded in\n\
1433 the target's charset.\n\
1434 An error setting \"error\" causes an exception to be thrown if there's\n\
1435 a decoding error. An error setting of \"substitute\" causes invalid\n\
1436 characters to be replaced with \"?\". The default is \"error\".\n\
1437 If LENGTH is provided, only fetch string to the length provided.\n\
1439 Arguments: <gdb:value>\n\
1440 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1441 [#:length length]" },
1443 { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
1445 Return a Scheme object representing a lazily fetched Unicode string\n\
1446 of the value's contents.\n\
1447 If ENCODING is not given, the string is assumed to be encoded in\n\
1448 the target's charset.\n\
1449 If LENGTH is provided, only fetch string to the length provided.\n\
1451 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1453 { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
1455 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1456 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1459 { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
1461 Create a <gdb:value> that will be lazily fetched from the target.\n\
1463 Arguments: <gdb:type> address" },
1465 { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
1467 Fetch the value from the inferior, if it was lazy.\n\
1468 The result is \"unspecified\"." },
1470 { "value-print", 1, 0, 0, gdbscm_value_print,
1472 Return the string representation (print form) of the value." },
1474 { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
1476 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1478 { "history-ref", 1, 0, 0, gdbscm_history_ref,
1480 Return the specified value from GDB's value history." },
1482 { "history-append!", 1, 0, 0, gdbscm_history_append_x,
1484 Append the specified value onto GDB's value history." },
1490 gdbscm_initialize_values (void)
1492 value_smob_tag = gdbscm_make_smob_type (value_smob_name,
1493 sizeof (value_smob));
1494 scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
1495 scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
1496 scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
1498 gdbscm_define_functions (value_functions, 1);
1500 type_keyword = scm_from_latin1_keyword ("type");
1501 encoding_keyword = scm_from_latin1_keyword ("encoding");
1502 errors_keyword = scm_from_latin1_keyword ("errors");
1503 length_keyword = scm_from_latin1_keyword ("length");
1505 error_symbol = scm_from_latin1_symbol ("error");
1506 escape_symbol = scm_from_latin1_symbol ("escape");
1507 substitute_symbol = scm_from_latin1_symbol ("substitute");