1 /* Scheme interface to values.
3 Copyright (C) 2008-2020 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 "target-float.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 "free" function for <gdb:value>. */
129 vlscm_free_value_smob (SCM self
)
131 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
133 vlscm_forget_value_smob (v_smob
);
134 value_decref (v_smob
->value
);
139 /* The smob "print" function for <gdb:value>. */
142 vlscm_print_value_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
144 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
145 struct value_print_options opts
;
147 if (pstate
->writingp
)
148 gdbscm_printf (port
, "#<%s ", value_smob_name
);
150 get_user_print_options (&opts
);
153 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
154 invoked by write/~S. What to do here may need to evolve.
155 IWBN if we could pass an argument to format that would we could use
156 instead of writingp. */
157 opts
.raw
= !!pstate
->writingp
;
159 gdbscm_gdb_exception exc
{};
164 common_val_print (v_smob
->value
, &stb
, 0, &opts
, current_language
);
165 scm_puts (stb
.c_str (), port
);
167 catch (const gdb_exception
&except
)
169 exc
= unpack (except
);
172 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
173 if (pstate
->writingp
)
174 scm_puts (">", port
);
176 scm_remember_upto_here_1 (self
);
178 /* Non-zero means success. */
182 /* The smob "equalp" function for <gdb:value>. */
185 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
187 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
188 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
191 gdbscm_gdb_exception exc
{};
194 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
196 catch (const gdb_exception
&except
)
198 exc
= unpack (except
);
201 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
202 return scm_from_bool (result
);
205 /* Low level routine to create a <gdb:value> object. */
208 vlscm_make_value_smob (void)
210 value_smob
*v_smob
= (value_smob
*)
211 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
214 /* These must be filled in by the caller. */
215 v_smob
->value
= NULL
;
219 /* These are lazily computed. */
220 v_smob
->address
= SCM_UNDEFINED
;
221 v_smob
->type
= SCM_UNDEFINED
;
222 v_smob
->dynamic_type
= SCM_UNDEFINED
;
224 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
225 gdbscm_init_gsmob (&v_smob
->base
);
230 /* Return non-zero if SCM is a <gdb:value> object. */
233 vlscm_is_value (SCM scm
)
235 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
238 /* (value? object) -> boolean */
241 gdbscm_value_p (SCM scm
)
243 return scm_from_bool (vlscm_is_value (scm
));
246 /* Create a new <gdb:value> object that encapsulates VALUE.
247 The value is released from the all_values chain so its lifetime is not
248 bound to the execution of a command. */
251 vlscm_scm_from_value (struct value
*value
)
253 /* N.B. It's important to not cause any side-effects until we know the
254 conversion worked. */
255 SCM v_scm
= vlscm_make_value_smob ();
256 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
258 v_smob
->value
= release_value (value
).release ();
259 vlscm_remember_scheme_value (v_smob
);
264 /* Create a new <gdb:value> object that encapsulates VALUE.
265 The value is not released from the all_values chain. */
268 vlscm_scm_from_value_no_release (struct value
*value
)
270 /* N.B. It's important to not cause any side-effects until we know the
271 conversion worked. */
272 SCM v_scm
= vlscm_make_value_smob ();
273 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
275 value_incref (value
);
276 v_smob
->value
= value
;
277 vlscm_remember_scheme_value (v_smob
);
282 /* Returns the <gdb:value> object in SELF.
283 Throws an exception if SELF is not a <gdb:value> object. */
286 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
288 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
294 /* Returns a pointer to the value smob of SELF.
295 Throws an exception if SELF is not a <gdb:value> object. */
298 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
300 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
301 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
306 /* Return the value field of V_SCM, an object of type <gdb:value>.
307 This exists so that we don't have to export the struct's contents. */
310 vlscm_scm_to_value (SCM v_scm
)
314 gdb_assert (vlscm_is_value (v_scm
));
315 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
316 return v_smob
->value
;
321 /* (make-value x [#:type type]) -> <gdb:value> */
324 gdbscm_make_value (SCM x
, SCM rest
)
326 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
328 int type_arg_pos
= -1;
329 SCM type_scm
= SCM_UNDEFINED
;
330 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
331 &type_arg_pos
, &type_scm
);
333 struct type
*type
= NULL
;
334 if (type_arg_pos
> 0)
336 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
339 type
= tyscm_type_smob_type (t_smob
);
342 return gdbscm_wrap ([=]
344 scoped_value_mark free_values
;
348 = vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
349 type_arg_pos
, type_scm
, type
,
356 return vlscm_scm_from_value (value
);
360 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
363 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
365 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
366 SCM_ARG1
, FUNC_NAME
);
367 struct type
*type
= tyscm_type_smob_type (t_smob
);
370 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
371 address_scm
, &address
);
373 return gdbscm_wrap ([=]
375 scoped_value_mark free_values
;
377 struct value
*value
= value_from_contents_and_address (type
, NULL
,
379 return vlscm_scm_from_value (value
);
383 /* (value-optimized-out? <gdb:value>) -> boolean */
386 gdbscm_value_optimized_out_p (SCM self
)
389 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
391 return gdbscm_wrap ([=]
393 return scm_from_bool (value_optimized_out (v_smob
->value
));
397 /* (value-address <gdb:value>) -> integer
398 Returns #f if the value doesn't have one. */
401 gdbscm_value_address (SCM self
)
404 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
405 struct value
*value
= v_smob
->value
;
407 return gdbscm_wrap ([=]
409 if (SCM_UNBNDP (v_smob
->address
))
411 scoped_value_mark free_values
;
413 SCM address
= SCM_BOOL_F
;
417 address
= vlscm_scm_from_value (value_addr (value
));
419 catch (const gdb_exception
&except
)
423 if (gdbscm_is_exception (address
))
426 v_smob
->address
= address
;
429 return v_smob
->address
;
433 /* (value-dereference <gdb:value>) -> <gdb:value>
434 Given a value of a pointer type, apply the C unary * operator to it. */
437 gdbscm_value_dereference (SCM self
)
440 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
442 return gdbscm_wrap ([=]
444 scoped_value_mark free_values
;
446 struct value
*res_val
= value_ind (v_smob
->value
);
447 return vlscm_scm_from_value (res_val
);
451 /* (value-referenced-value <gdb:value>) -> <gdb:value>
452 Given a value of a reference type, return the value referenced.
453 The difference between this function and gdbscm_value_dereference is that
454 the latter applies * unary operator to a value, which need not always
455 result in the value referenced.
456 For example, for a value which is a reference to an 'int' pointer ('int *'),
457 gdbscm_value_dereference will result in a value of type 'int' while
458 gdbscm_value_referenced_value will result in a value of type 'int *'. */
461 gdbscm_value_referenced_value (SCM self
)
464 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
465 struct value
*value
= v_smob
->value
;
467 return gdbscm_wrap ([=]
469 scoped_value_mark free_values
;
471 struct value
*res_val
;
473 switch (TYPE_CODE (check_typedef (value_type (value
))))
476 res_val
= value_ind (value
);
479 res_val
= coerce_ref (value
);
482 error (_("Trying to get the referenced value from a value which is"
483 " neither a pointer nor a reference"));
486 return vlscm_scm_from_value (res_val
);
490 /* (value-type <gdb:value>) -> <gdb:type> */
493 gdbscm_value_type (SCM self
)
496 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
497 struct value
*value
= v_smob
->value
;
499 if (SCM_UNBNDP (v_smob
->type
))
500 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
505 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
508 gdbscm_value_dynamic_type (SCM self
)
511 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
512 struct value
*value
= v_smob
->value
;
513 struct type
*type
= NULL
;
515 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
516 return v_smob
->dynamic_type
;
518 gdbscm_gdb_exception exc
{};
521 scoped_value_mark free_values
;
523 type
= value_type (value
);
524 type
= check_typedef (type
);
526 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
527 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
528 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
530 struct value
*target
;
531 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
534 target
= value_ind (value
);
536 target
= coerce_ref (value
);
537 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
542 type
= lookup_pointer_type (type
);
544 type
= lookup_lvalue_reference_type (type
);
547 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
548 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
551 /* Re-use object's static type. */
555 catch (const gdb_exception
&except
)
557 exc
= unpack (except
);
560 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
562 v_smob
->dynamic_type
= gdbscm_value_type (self
);
564 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
566 return v_smob
->dynamic_type
;
569 /* A helper function that implements the various cast operators. */
572 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
573 const char *func_name
)
576 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
577 struct value
*value
= v_smob
->value
;
579 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
580 struct type
*type
= tyscm_type_smob_type (t_smob
);
582 return gdbscm_wrap ([=]
584 scoped_value_mark free_values
;
586 struct value
*res_val
;
587 if (op
== UNOP_DYNAMIC_CAST
)
588 res_val
= value_dynamic_cast (type
, value
);
589 else if (op
== UNOP_REINTERPRET_CAST
)
590 res_val
= value_reinterpret_cast (type
, value
);
593 gdb_assert (op
== UNOP_CAST
);
594 res_val
= value_cast (type
, value
);
597 return vlscm_scm_from_value (res_val
);
601 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
604 gdbscm_value_cast (SCM self
, SCM new_type
)
606 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
609 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
612 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
614 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
617 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
620 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
622 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
625 /* (value-field <gdb:value> string) -> <gdb:value>
626 Given string name of an element inside structure, return its <gdb:value>
630 gdbscm_value_field (SCM self
, SCM field_scm
)
633 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
635 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
638 return gdbscm_wrap ([=]
640 scoped_value_mark free_values
;
642 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
644 struct value
*tmp
= v_smob
->value
;
646 struct value
*res_val
= value_struct_elt (&tmp
, NULL
, field
.get (), NULL
,
647 "struct/class/union");
649 return vlscm_scm_from_value (res_val
);
653 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
654 Return the specified value in an array. */
657 gdbscm_value_subscript (SCM self
, SCM index_scm
)
660 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
661 struct value
*value
= v_smob
->value
;
662 struct type
*type
= value_type (value
);
664 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
666 return gdbscm_wrap ([=]
668 scoped_value_mark free_values
;
672 = vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
674 get_type_arch (type
),
679 /* Assume we are attempting an array access, and let the value code
680 throw an exception if the index has an invalid type.
681 Check the value's type is something that can be accessed via
683 struct value
*tmp
= coerce_ref (value
);
684 struct type
*tmp_type
= check_typedef (value_type (tmp
));
685 if (TYPE_CODE (tmp_type
) != TYPE_CODE_ARRAY
686 && TYPE_CODE (tmp_type
) != TYPE_CODE_PTR
)
687 error (_("Cannot subscript requested type"));
689 struct value
*res_val
= value_subscript (tmp
, value_as_long (index
));
690 return vlscm_scm_from_value (res_val
);
694 /* (value-call <gdb:value> arg-list) -> <gdb:value>
695 Perform an inferior function call on the value. */
698 gdbscm_value_call (SCM self
, SCM args
)
701 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
702 struct value
*function
= v_smob
->value
;
703 struct type
*ftype
= NULL
;
705 struct value
**vargs
= NULL
;
707 gdbscm_gdb_exception exc
{};
710 ftype
= check_typedef (value_type (function
));
712 catch (const gdb_exception
&except
)
714 exc
= unpack (except
);
717 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
718 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
720 _("function (value of TYPE_CODE_FUNC)"));
722 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
723 SCM_ARG2
, FUNC_NAME
, _("list"));
725 args_count
= scm_ilength (args
);
728 struct gdbarch
*gdbarch
= get_current_arch ();
729 const struct language_defn
*language
= current_language
;
733 vargs
= XALLOCAVEC (struct value
*, args_count
);
734 for (i
= 0; i
< args_count
; i
++)
736 SCM arg
= scm_car (args
);
738 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
739 GDBSCM_ARG_NONE
, arg
,
742 if (vargs
[i
] == NULL
)
743 gdbscm_throw (except_scm
);
745 args
= scm_cdr (args
);
747 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
750 return gdbscm_wrap ([=]
752 scoped_value_mark free_values
;
754 auto av
= gdb::make_array_view (vargs
, args_count
);
755 value
*return_value
= call_function_by_hand (function
, NULL
, av
);
756 return vlscm_scm_from_value (return_value
);
760 /* (value->bytevector <gdb:value>) -> bytevector */
763 gdbscm_value_to_bytevector (SCM self
)
766 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
767 struct value
*value
= v_smob
->value
;
770 const gdb_byte
*contents
= NULL
;
773 type
= value_type (value
);
775 gdbscm_gdb_exception exc
{};
778 type
= check_typedef (type
);
779 length
= TYPE_LENGTH (type
);
780 contents
= value_contents (value
);
782 catch (const gdb_exception
&except
)
784 exc
= unpack (except
);
787 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
788 bv
= scm_c_make_bytevector (length
);
789 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
794 /* Helper function to determine if a type is "int-like". */
797 is_intlike (struct type
*type
, int ptr_ok
)
799 return (TYPE_CODE (type
) == TYPE_CODE_INT
800 || TYPE_CODE (type
) == TYPE_CODE_ENUM
801 || TYPE_CODE (type
) == TYPE_CODE_BOOL
802 || TYPE_CODE (type
) == TYPE_CODE_CHAR
803 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
806 /* (value->bool <gdb:value>) -> boolean
807 Throws an error if the value is not integer-like. */
810 gdbscm_value_to_bool (SCM self
)
813 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
814 struct value
*value
= v_smob
->value
;
818 type
= value_type (value
);
820 gdbscm_gdb_exception exc
{};
823 type
= check_typedef (type
);
825 catch (const gdb_exception
&except
)
827 exc
= unpack (except
);
830 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
831 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
832 _("integer-like gdb value"));
836 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
837 l
= value_as_address (value
);
839 l
= value_as_long (value
);
841 catch (const gdb_exception
&except
)
843 exc
= unpack (except
);
846 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
847 return scm_from_bool (l
!= 0);
850 /* (value->integer <gdb:value>) -> integer
851 Throws an error if the value is not integer-like. */
854 gdbscm_value_to_integer (SCM self
)
857 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
858 struct value
*value
= v_smob
->value
;
862 type
= value_type (value
);
864 gdbscm_gdb_exception exc
{};
867 type
= check_typedef (type
);
869 catch (const gdb_exception
&except
)
871 exc
= unpack (except
);
874 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
875 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
876 _("integer-like gdb value"));
880 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
881 l
= value_as_address (value
);
883 l
= value_as_long (value
);
885 catch (const gdb_exception
&except
)
887 exc
= unpack (except
);
890 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
891 if (TYPE_UNSIGNED (type
))
892 return gdbscm_scm_from_ulongest (l
);
894 return gdbscm_scm_from_longest (l
);
897 /* (value->real <gdb:value>) -> real
898 Throws an error if the value is not a number. */
901 gdbscm_value_to_real (SCM self
)
904 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
905 struct value
*value
= v_smob
->value
;
908 struct value
*check
= nullptr;
910 type
= value_type (value
);
912 gdbscm_gdb_exception exc
{};
915 type
= check_typedef (type
);
917 catch (const gdb_exception
&except
)
919 exc
= unpack (except
);
922 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
923 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
924 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
928 if (is_floating_value (value
))
930 d
= target_float_to_host_double (value_contents (value
), type
);
931 check
= value_from_host_double (type
, d
);
933 else if (TYPE_UNSIGNED (type
))
935 d
= (ULONGEST
) value_as_long (value
);
936 check
= value_from_ulongest (type
, (ULONGEST
) d
);
940 d
= value_as_long (value
);
941 check
= value_from_longest (type
, (LONGEST
) d
);
944 catch (const gdb_exception
&except
)
946 exc
= unpack (except
);
949 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
950 /* TODO: Is there a better way to check if the value fits? */
951 if (!value_equal (value
, check
))
952 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
953 _("number can't be converted to a double"));
955 return scm_from_double (d
);
958 /* (value->string <gdb:value>
959 [#:encoding encoding]
960 [#:errors #f | 'error | 'substitute]
963 Return Unicode string with value's contents, which must be a string.
965 If ENCODING is not given, the string is assumed to be encoded in
966 the target's charset.
968 ERRORS is one of #f, 'error or 'substitute.
969 An error setting of #f means use the default, which is Guile's
970 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
971 using an earlier version of Guile. Earlier versions do not properly
972 support obtaining the default port conversion strategy.
973 If the default is not one of 'error or 'substitute, 'substitute is used.
974 An error setting of "error" causes an exception to be thrown if there's
975 a decoding error. An error setting of "substitute" causes invalid
976 characters to be replaced with "?".
978 If LENGTH is provided, only fetch string to the length provided.
979 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
982 gdbscm_value_to_string (SCM self
, SCM rest
)
985 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
986 struct value
*value
= v_smob
->value
;
987 const SCM keywords
[] = {
988 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
990 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
991 char *encoding
= NULL
;
992 SCM errors
= SCM_BOOL_F
;
993 /* Avoid an uninitialized warning from gcc. */
994 gdb_byte
*buffer_contents
= nullptr;
996 const char *la_encoding
= NULL
;
997 struct type
*char_type
= NULL
;
1000 /* The sequencing here, as everywhere else, is important.
1001 We can't have existing cleanups when a Scheme exception is thrown. */
1003 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1004 &encoding_arg_pos
, &encoding
,
1005 &errors_arg_pos
, &errors
,
1006 &length_arg_pos
, &length
);
1008 if (errors_arg_pos
> 0
1009 && errors
!= SCM_BOOL_F
1010 && !scm_is_eq (errors
, error_symbol
)
1011 && !scm_is_eq (errors
, substitute_symbol
))
1014 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1015 _("invalid error kind"));
1018 gdbscm_throw (excp
);
1020 if (errors
== SCM_BOOL_F
)
1022 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1023 will throw a Scheme error when passed #f. */
1024 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1025 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1027 errors
= error_symbol
;
1029 /* We don't assume anything about the result of scm_port_conversion_strategy.
1030 From this point on, if errors is not 'errors, use 'substitute. */
1032 gdbscm_gdb_exception exc
{};
1035 gdb::unique_xmalloc_ptr
<gdb_byte
> buffer
;
1036 c_get_string (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1037 buffer_contents
= buffer
.release ();
1039 catch (const gdb_exception
&except
)
1042 exc
= unpack (except
);
1044 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
1046 /* If errors is "error", scm_from_stringn may throw a Scheme exception.
1047 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1049 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1051 gdbscm_dynwind_xfree (encoding
);
1052 gdbscm_dynwind_xfree (buffer_contents
);
1054 result
= scm_from_stringn ((const char *) buffer_contents
,
1055 length
* TYPE_LENGTH (char_type
),
1056 (encoding
!= NULL
&& *encoding
!= '\0'
1059 scm_is_eq (errors
, error_symbol
)
1060 ? SCM_FAILED_CONVERSION_ERROR
1061 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1068 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1069 -> <gdb:lazy-string>
1070 Return a Scheme object representing a lazy_string_object type.
1071 A lazy string is a pointer to a string with an optional encoding and length.
1072 If ENCODING is not given, the target's charset is used.
1073 If LENGTH is provided then the length parameter is set to LENGTH.
1074 Otherwise if the value is an array of known length then the array's length
1075 is used. Otherwise the length will be set to -1 (meaning first null of
1077 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1080 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1083 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1084 struct value
*value
= v_smob
->value
;
1085 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1086 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1087 char *encoding
= NULL
;
1089 SCM result
= SCM_BOOL_F
; /* -Wall */
1090 gdbscm_gdb_exception except
{};
1092 /* The sequencing here, as everywhere else, is important.
1093 We can't have existing cleanups when a Scheme exception is thrown. */
1095 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1096 &encoding_arg_pos
, &encoding
,
1097 &length_arg_pos
, &length
);
1101 gdbscm_out_of_range_error (FUNC_NAME
, length_arg_pos
,
1102 scm_from_int (length
),
1103 _("invalid length"));
1108 scoped_value_mark free_values
;
1110 struct type
*type
, *realtype
;
1113 type
= value_type (value
);
1114 realtype
= check_typedef (type
);
1116 switch (TYPE_CODE (realtype
))
1118 case TYPE_CODE_ARRAY
:
1120 LONGEST array_length
= -1;
1121 LONGEST low_bound
, high_bound
;
1123 /* PR 20786: There's no way to specify an array of length zero.
1124 Record a length of [0,-1] which is how Ada does it. Anything
1125 we do is broken, but this one possible solution. */
1126 if (get_array_bounds (realtype
, &low_bound
, &high_bound
))
1127 array_length
= high_bound
- low_bound
+ 1;
1129 length
= array_length
;
1130 else if (array_length
== -1)
1132 type
= lookup_array_range_type (TYPE_TARGET_TYPE (realtype
),
1135 else if (length
!= array_length
)
1137 /* We need to create a new array type with the
1138 specified length. */
1139 if (length
> array_length
)
1140 error (_("length is larger than array size"));
1141 type
= lookup_array_range_type (TYPE_TARGET_TYPE (type
),
1143 low_bound
+ length
- 1);
1145 addr
= value_address (value
);
1149 /* If a length is specified we defer creating an array of the
1150 specified width until we need to. */
1151 addr
= value_as_address (value
);
1154 /* Should flag an error here. PR 20769. */
1155 addr
= value_address (value
);
1159 result
= lsscm_make_lazy_string (addr
, length
, encoding
, type
);
1161 catch (const gdb_exception
&ex
)
1163 except
= unpack (ex
);
1167 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1169 if (gdbscm_is_exception (result
))
1170 gdbscm_throw (result
);
1175 /* (value-lazy? <gdb:value>) -> boolean */
1178 gdbscm_value_lazy_p (SCM self
)
1181 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1182 struct value
*value
= v_smob
->value
;
1184 return scm_from_bool (value_lazy (value
));
1187 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1190 gdbscm_value_fetch_lazy_x (SCM self
)
1193 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1194 struct value
*value
= v_smob
->value
;
1196 return gdbscm_wrap ([=]
1198 if (value_lazy (value
))
1199 value_fetch_lazy (value
);
1200 return SCM_UNSPECIFIED
;
1204 /* (value-print <gdb:value>) -> string */
1207 gdbscm_value_print (SCM self
)
1210 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1211 struct value
*value
= v_smob
->value
;
1212 struct value_print_options opts
;
1214 get_user_print_options (&opts
);
1219 gdbscm_gdb_exception exc
{};
1222 common_val_print (value
, &stb
, 0, &opts
, current_language
);
1224 catch (const gdb_exception
&except
)
1226 exc
= unpack (except
);
1229 GDBSCM_HANDLE_GDB_EXCEPTION (exc
);
1230 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1231 throw an error if the encoding fails.
1232 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1233 override the default port conversion handler because contrary to
1234 documentation it doesn't necessarily free the input string. */
1235 return scm_from_stringn (stb
.c_str (), stb
.size (), host_charset (),
1236 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 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1247 expr_scm
, &expr_str
);
1249 return gdbscm_wrap ([=]
1251 scoped_value_mark free_values
;
1252 return vlscm_scm_from_value (parse_and_eval (expr_str
));
1256 /* (history-ref integer) -> <gdb:value>
1257 Return the specified value from GDB's value history. */
1260 gdbscm_history_ref (SCM index
)
1263 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1265 return gdbscm_wrap ([=]
1267 return vlscm_scm_from_value (access_value_history (i
));
1271 /* (history-append! <gdb:value>) -> index
1272 Append VALUE to GDB's value history. Return its index in the history. */
1275 gdbscm_history_append_x (SCM value
)
1278 = vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1279 return gdbscm_wrap ([=]
1281 return scm_from_int (record_latest_value (v_smob
->value
));
1285 /* Initialize the Scheme value code. */
1287 static const scheme_function value_functions
[] =
1289 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1291 Return #t if the object is a <gdb:value> object." },
1293 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1295 Create a <gdb:value> representing object.\n\
1296 Typically this is used to convert numbers and strings to\n\
1297 <gdb:value> objects.\n\
1299 Arguments: object [#:type <gdb:type>]" },
1301 { "value-optimized-out?", 1, 0, 0,
1302 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1304 Return #t if the value has been optimizd out." },
1306 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1308 Return the address of the value." },
1310 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1312 Return the type of the value." },
1314 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1316 Return the dynamic type of the value." },
1318 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1320 Cast the value to the supplied type.\n\
1322 Arguments: <gdb:value> <gdb:type>" },
1324 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1326 Cast the value to the supplied type, as if by the C++\n\
1327 dynamic_cast operator.\n\
1329 Arguments: <gdb:value> <gdb:type>" },
1331 { "value-reinterpret-cast", 2, 0, 0,
1332 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1334 Cast the value to the supplied type, as if by the C++\n\
1335 reinterpret_cast operator.\n\
1337 Arguments: <gdb:value> <gdb:type>" },
1339 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1341 Return the result of applying the C unary * operator to the value." },
1343 { "value-referenced-value", 1, 0, 0,
1344 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1346 Given a value of a reference type, return the value referenced.\n\
1347 The difference between this function and value-dereference is that\n\
1348 the latter applies * unary operator to a value, which need not always\n\
1349 result in the value referenced.\n\
1350 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1351 value-dereference will result in a value of type 'int' while\n\
1352 value-referenced-value will result in a value of type 'int *'." },
1354 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1356 Return the specified field of the value.\n\
1358 Arguments: <gdb:value> string" },
1360 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1362 Return the value of the array at the specified index.\n\
1364 Arguments: <gdb:value> integer" },
1366 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1368 Perform an inferior function call taking the value as a pointer to the\n\
1369 function to call.\n\
1370 Each element of the argument list must be a <gdb:value> object or an object\n\
1371 that can be converted to one.\n\
1372 The result is the value returned by the function.\n\
1374 Arguments: <gdb:value> arg-list" },
1376 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1378 Return the Scheme boolean representing the GDB value.\n\
1379 The value must be \"integer like\". Pointers are ok." },
1381 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1383 Return the Scheme integer representing the GDB value.\n\
1384 The value must be \"integer like\". Pointers are ok." },
1386 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1388 Return the Scheme real number representing the GDB value.\n\
1389 The value must be a number." },
1391 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1393 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1394 No transformation, endian or otherwise, is performed." },
1396 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1398 Return the Unicode string of the value's contents.\n\
1399 If ENCODING is not given, the string is assumed to be encoded in\n\
1400 the target's charset.\n\
1401 An error setting \"error\" causes an exception to be thrown if there's\n\
1402 a decoding error. An error setting of \"substitute\" causes invalid\n\
1403 characters to be replaced with \"?\". The default is \"error\".\n\
1404 If LENGTH is provided, only fetch string to the length provided.\n\
1406 Arguments: <gdb:value>\n\
1407 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1408 [#:length length]" },
1410 { "value->lazy-string", 1, 0, 1,
1411 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1413 Return a Scheme object representing a lazily fetched Unicode string\n\
1414 of the value's contents.\n\
1415 If ENCODING is not given, the string is assumed to be encoded in\n\
1416 the target's charset.\n\
1417 If LENGTH is provided, only fetch string to the length provided.\n\
1419 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1421 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1423 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1424 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1427 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1429 Create a <gdb:value> that will be lazily fetched from the target.\n\
1431 Arguments: <gdb:type> address" },
1433 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1435 Fetch the value from the inferior, if it was lazy.\n\
1436 The result is \"unspecified\"." },
1438 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1440 Return the string representation (print form) of the value." },
1442 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1444 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1446 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1448 Return the specified value from GDB's value history." },
1450 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1452 Append the specified value onto GDB's value history." },
1458 gdbscm_initialize_values (void)
1460 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1461 sizeof (value_smob
));
1462 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1463 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1464 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1466 gdbscm_define_functions (value_functions
, 1);
1468 type_keyword
= scm_from_latin1_keyword ("type");
1469 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1470 errors_keyword
= scm_from_latin1_keyword ("errors");
1471 length_keyword
= scm_from_latin1_keyword ("length");
1473 error_symbol
= scm_from_latin1_symbol ("error");
1474 escape_symbol
= scm_from_latin1_symbol ("escape");
1475 substitute_symbol
= scm_from_latin1_symbol ("substitute");