1 /* Scheme interface to values.
3 Copyright (C) 2008-2019 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
;
163 common_val_print (v_smob
->value
, &stb
, 0, &opts
, current_language
);
164 scm_puts (stb
.c_str (), port
);
166 catch (const gdb_exception
&except
)
168 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
171 if (pstate
->writingp
)
172 scm_puts (">", port
);
174 scm_remember_upto_here_1 (self
);
176 /* Non-zero means success. */
180 /* The smob "equalp" function for <gdb:value>. */
183 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
185 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
186 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
191 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
193 catch (const gdb_exception
&except
)
195 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
198 return scm_from_bool (result
);
201 /* Low level routine to create a <gdb:value> object. */
204 vlscm_make_value_smob (void)
206 value_smob
*v_smob
= (value_smob
*)
207 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
210 /* These must be filled in by the caller. */
211 v_smob
->value
= NULL
;
215 /* These are lazily computed. */
216 v_smob
->address
= SCM_UNDEFINED
;
217 v_smob
->type
= SCM_UNDEFINED
;
218 v_smob
->dynamic_type
= SCM_UNDEFINED
;
220 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
221 gdbscm_init_gsmob (&v_smob
->base
);
226 /* Return non-zero if SCM is a <gdb:value> object. */
229 vlscm_is_value (SCM scm
)
231 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
234 /* (value? object) -> boolean */
237 gdbscm_value_p (SCM scm
)
239 return scm_from_bool (vlscm_is_value (scm
));
242 /* Create a new <gdb:value> object that encapsulates VALUE.
243 The value is released from the all_values chain so its lifetime is not
244 bound to the execution of a command. */
247 vlscm_scm_from_value (struct value
*value
)
249 /* N.B. It's important to not cause any side-effects until we know the
250 conversion worked. */
251 SCM v_scm
= vlscm_make_value_smob ();
252 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
254 v_smob
->value
= release_value (value
).release ();
255 vlscm_remember_scheme_value (v_smob
);
260 /* Returns the <gdb:value> object in SELF.
261 Throws an exception if SELF is not a <gdb:value> object. */
264 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
266 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
272 /* Returns a pointer to the value smob of SELF.
273 Throws an exception if SELF is not a <gdb:value> object. */
276 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
278 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
279 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
284 /* Return the value field of V_SCM, an object of type <gdb:value>.
285 This exists so that we don't have to export the struct's contents. */
288 vlscm_scm_to_value (SCM v_scm
)
292 gdb_assert (vlscm_is_value (v_scm
));
293 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
294 return v_smob
->value
;
299 /* (make-value x [#:type type]) -> <gdb:value> */
302 gdbscm_make_value (SCM x
, SCM rest
)
304 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
306 int type_arg_pos
= -1;
307 SCM type_scm
= SCM_UNDEFINED
;
308 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
309 &type_arg_pos
, &type_scm
);
311 struct type
*type
= NULL
;
312 if (type_arg_pos
> 0)
314 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
317 type
= tyscm_type_smob_type (t_smob
);
320 return gdbscm_wrap ([=]
322 scoped_value_mark free_values
;
326 = vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
327 type_arg_pos
, type_scm
, type
,
334 return vlscm_scm_from_value (value
);
338 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
341 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
343 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
344 SCM_ARG1
, FUNC_NAME
);
345 struct type
*type
= tyscm_type_smob_type (t_smob
);
348 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
349 address_scm
, &address
);
351 return gdbscm_wrap ([=]
353 scoped_value_mark free_values
;
355 struct value
*value
= value_from_contents_and_address (type
, NULL
,
357 return vlscm_scm_from_value (value
);
361 /* (value-optimized-out? <gdb:value>) -> boolean */
364 gdbscm_value_optimized_out_p (SCM self
)
367 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
369 return gdbscm_wrap ([=]
371 return scm_from_bool (value_optimized_out (v_smob
->value
));
375 /* (value-address <gdb:value>) -> integer
376 Returns #f if the value doesn't have one. */
379 gdbscm_value_address (SCM self
)
382 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
383 struct value
*value
= v_smob
->value
;
385 return gdbscm_wrap ([=]
387 if (SCM_UNBNDP (v_smob
->address
))
389 scoped_value_mark free_values
;
391 SCM address
= SCM_BOOL_F
;
395 address
= vlscm_scm_from_value (value_addr (value
));
397 catch (const gdb_exception
&except
)
401 if (gdbscm_is_exception (address
))
404 v_smob
->address
= address
;
407 return v_smob
->address
;
411 /* (value-dereference <gdb:value>) -> <gdb:value>
412 Given a value of a pointer type, apply the C unary * operator to it. */
415 gdbscm_value_dereference (SCM self
)
418 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
420 return gdbscm_wrap ([=]
422 scoped_value_mark free_values
;
424 struct value
*res_val
= value_ind (v_smob
->value
);
425 return vlscm_scm_from_value (res_val
);
429 /* (value-referenced-value <gdb:value>) -> <gdb:value>
430 Given a value of a reference type, return the value referenced.
431 The difference between this function and gdbscm_value_dereference is that
432 the latter applies * unary operator to a value, which need not always
433 result in the value referenced.
434 For example, for a value which is a reference to an 'int' pointer ('int *'),
435 gdbscm_value_dereference will result in a value of type 'int' while
436 gdbscm_value_referenced_value will result in a value of type 'int *'. */
439 gdbscm_value_referenced_value (SCM self
)
442 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
443 struct value
*value
= v_smob
->value
;
445 return gdbscm_wrap ([=]
447 scoped_value_mark free_values
;
449 struct value
*res_val
;
451 switch (TYPE_CODE (check_typedef (value_type (value
))))
454 res_val
= value_ind (value
);
457 res_val
= coerce_ref (value
);
460 error (_("Trying to get the referenced value from a value which is"
461 " neither a pointer nor a reference"));
464 return vlscm_scm_from_value (res_val
);
468 /* (value-type <gdb:value>) -> <gdb:type> */
471 gdbscm_value_type (SCM self
)
474 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
475 struct value
*value
= v_smob
->value
;
477 if (SCM_UNBNDP (v_smob
->type
))
478 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
483 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
486 gdbscm_value_dynamic_type (SCM self
)
489 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
490 struct value
*value
= v_smob
->value
;
491 struct type
*type
= NULL
;
493 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
494 return v_smob
->dynamic_type
;
498 scoped_value_mark free_values
;
500 type
= value_type (value
);
501 type
= check_typedef (type
);
503 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
504 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
505 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
507 struct value
*target
;
508 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
511 target
= value_ind (value
);
513 target
= coerce_ref (value
);
514 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
519 type
= lookup_pointer_type (type
);
521 type
= lookup_lvalue_reference_type (type
);
524 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
525 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
528 /* Re-use object's static type. */
532 catch (const gdb_exception
&except
)
534 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
538 v_smob
->dynamic_type
= gdbscm_value_type (self
);
540 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
542 return v_smob
->dynamic_type
;
545 /* A helper function that implements the various cast operators. */
548 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
549 const char *func_name
)
552 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
553 struct value
*value
= v_smob
->value
;
555 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
556 struct type
*type
= tyscm_type_smob_type (t_smob
);
558 return gdbscm_wrap ([=]
560 scoped_value_mark free_values
;
562 struct value
*res_val
;
563 if (op
== UNOP_DYNAMIC_CAST
)
564 res_val
= value_dynamic_cast (type
, value
);
565 else if (op
== UNOP_REINTERPRET_CAST
)
566 res_val
= value_reinterpret_cast (type
, value
);
569 gdb_assert (op
== UNOP_CAST
);
570 res_val
= value_cast (type
, value
);
573 return vlscm_scm_from_value (res_val
);
577 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
580 gdbscm_value_cast (SCM self
, SCM new_type
)
582 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
585 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
588 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
590 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
593 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
596 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
598 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
601 /* (value-field <gdb:value> string) -> <gdb:value>
602 Given string name of an element inside structure, return its <gdb:value>
606 gdbscm_value_field (SCM self
, SCM field_scm
)
609 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
611 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
614 return gdbscm_wrap ([=]
616 scoped_value_mark free_values
;
618 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
620 struct value
*tmp
= v_smob
->value
;
622 struct value
*res_val
= value_struct_elt (&tmp
, NULL
, field
.get (), NULL
,
623 "struct/class/union");
625 return vlscm_scm_from_value (res_val
);
629 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
630 Return the specified value in an array. */
633 gdbscm_value_subscript (SCM self
, SCM index_scm
)
636 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
637 struct value
*value
= v_smob
->value
;
638 struct type
*type
= value_type (value
);
640 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
642 return gdbscm_wrap ([=]
644 scoped_value_mark free_values
;
648 = vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
650 get_type_arch (type
),
655 /* Assume we are attempting an array access, and let the value code
656 throw an exception if the index has an invalid type.
657 Check the value's type is something that can be accessed via
659 struct value
*tmp
= coerce_ref (value
);
660 struct type
*tmp_type
= check_typedef (value_type (tmp
));
661 if (TYPE_CODE (tmp_type
) != TYPE_CODE_ARRAY
662 && TYPE_CODE (tmp_type
) != TYPE_CODE_PTR
)
663 error (_("Cannot subscript requested type"));
665 struct value
*res_val
= value_subscript (tmp
, value_as_long (index
));
666 return vlscm_scm_from_value (res_val
);
670 /* (value-call <gdb:value> arg-list) -> <gdb:value>
671 Perform an inferior function call on the value. */
674 gdbscm_value_call (SCM self
, SCM args
)
677 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
678 struct value
*function
= v_smob
->value
;
679 struct type
*ftype
= NULL
;
681 struct value
**vargs
= NULL
;
685 ftype
= check_typedef (value_type (function
));
687 catch (const gdb_exception
&except
)
689 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
692 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
694 _("function (value of TYPE_CODE_FUNC)"));
696 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
697 SCM_ARG2
, FUNC_NAME
, _("list"));
699 args_count
= scm_ilength (args
);
702 struct gdbarch
*gdbarch
= get_current_arch ();
703 const struct language_defn
*language
= current_language
;
707 vargs
= XALLOCAVEC (struct value
*, args_count
);
708 for (i
= 0; i
< args_count
; i
++)
710 SCM arg
= scm_car (args
);
712 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
713 GDBSCM_ARG_NONE
, arg
,
716 if (vargs
[i
] == NULL
)
717 gdbscm_throw (except_scm
);
719 args
= scm_cdr (args
);
721 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
724 return gdbscm_wrap ([=]
726 scoped_value_mark free_values
;
728 auto av
= gdb::make_array_view (vargs
, args_count
);
729 value
*return_value
= call_function_by_hand (function
, NULL
, av
);
730 return vlscm_scm_from_value (return_value
);
734 /* (value->bytevector <gdb:value>) -> bytevector */
737 gdbscm_value_to_bytevector (SCM self
)
740 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
741 struct value
*value
= v_smob
->value
;
744 const gdb_byte
*contents
= NULL
;
747 type
= value_type (value
);
751 type
= check_typedef (type
);
752 length
= TYPE_LENGTH (type
);
753 contents
= value_contents (value
);
755 catch (const gdb_exception
&except
)
757 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
760 bv
= scm_c_make_bytevector (length
);
761 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
766 /* Helper function to determine if a type is "int-like". */
769 is_intlike (struct type
*type
, int ptr_ok
)
771 return (TYPE_CODE (type
) == TYPE_CODE_INT
772 || TYPE_CODE (type
) == TYPE_CODE_ENUM
773 || TYPE_CODE (type
) == TYPE_CODE_BOOL
774 || TYPE_CODE (type
) == TYPE_CODE_CHAR
775 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
778 /* (value->bool <gdb:value>) -> boolean
779 Throws an error if the value is not integer-like. */
782 gdbscm_value_to_bool (SCM self
)
785 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
786 struct value
*value
= v_smob
->value
;
790 type
= value_type (value
);
794 type
= check_typedef (type
);
796 catch (const gdb_exception
&except
)
798 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
801 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
802 _("integer-like gdb value"));
806 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
807 l
= value_as_address (value
);
809 l
= value_as_long (value
);
811 catch (const gdb_exception
&except
)
813 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
816 return scm_from_bool (l
!= 0);
819 /* (value->integer <gdb:value>) -> integer
820 Throws an error if the value is not integer-like. */
823 gdbscm_value_to_integer (SCM self
)
826 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
827 struct value
*value
= v_smob
->value
;
831 type
= value_type (value
);
835 type
= check_typedef (type
);
837 catch (const gdb_exception
&except
)
839 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
842 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
843 _("integer-like gdb value"));
847 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
848 l
= value_as_address (value
);
850 l
= value_as_long (value
);
852 catch (const gdb_exception
&except
)
854 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
857 if (TYPE_UNSIGNED (type
))
858 return gdbscm_scm_from_ulongest (l
);
860 return gdbscm_scm_from_longest (l
);
863 /* (value->real <gdb:value>) -> real
864 Throws an error if the value is not a number. */
867 gdbscm_value_to_real (SCM self
)
870 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
871 struct value
*value
= v_smob
->value
;
874 struct value
*check
= nullptr;
876 type
= value_type (value
);
880 type
= check_typedef (type
);
882 catch (const gdb_exception
&except
)
884 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
887 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
888 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
892 if (is_floating_value (value
))
894 d
= target_float_to_host_double (value_contents (value
), type
);
895 check
= value_from_host_double (type
, d
);
897 else if (TYPE_UNSIGNED (type
))
899 d
= (ULONGEST
) value_as_long (value
);
900 check
= value_from_ulongest (type
, (ULONGEST
) d
);
904 d
= value_as_long (value
);
905 check
= value_from_longest (type
, (LONGEST
) d
);
908 catch (const gdb_exception
&except
)
910 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
913 /* TODO: Is there a better way to check if the value fits? */
914 if (!value_equal (value
, check
))
915 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
916 _("number can't be converted to a double"));
918 return scm_from_double (d
);
921 /* (value->string <gdb:value>
922 [#:encoding encoding]
923 [#:errors #f | 'error | 'substitute]
926 Return Unicode string with value's contents, which must be a string.
928 If ENCODING is not given, the string is assumed to be encoded in
929 the target's charset.
931 ERRORS is one of #f, 'error or 'substitute.
932 An error setting of #f means use the default, which is Guile's
933 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
934 using an earlier version of Guile. Earlier versions do not properly
935 support obtaining the default port conversion strategy.
936 If the default is not one of 'error or 'substitute, 'substitute is used.
937 An error setting of "error" causes an exception to be thrown if there's
938 a decoding error. An error setting of "substitute" causes invalid
939 characters to be replaced with "?".
941 If LENGTH is provided, only fetch string to the length provided.
942 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
945 gdbscm_value_to_string (SCM self
, SCM rest
)
948 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
949 struct value
*value
= v_smob
->value
;
950 const SCM keywords
[] = {
951 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
953 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
954 char *encoding
= NULL
;
955 SCM errors
= SCM_BOOL_F
;
956 /* Avoid an uninitialized warning from gcc. */
957 gdb_byte
*buffer_contents
= nullptr;
959 const char *la_encoding
= NULL
;
960 struct type
*char_type
= NULL
;
963 /* The sequencing here, as everywhere else, is important.
964 We can't have existing cleanups when a Scheme exception is thrown. */
966 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
967 &encoding_arg_pos
, &encoding
,
968 &errors_arg_pos
, &errors
,
969 &length_arg_pos
, &length
);
971 if (errors_arg_pos
> 0
972 && errors
!= SCM_BOOL_F
973 && !scm_is_eq (errors
, error_symbol
)
974 && !scm_is_eq (errors
, substitute_symbol
))
977 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
978 _("invalid error kind"));
983 if (errors
== SCM_BOOL_F
)
985 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
986 will throw a Scheme error when passed #f. */
987 if (gdbscm_guile_version_is_at_least (2, 0, 6))
988 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
990 errors
= error_symbol
;
992 /* We don't assume anything about the result of scm_port_conversion_strategy.
993 From this point on, if errors is not 'errors, use 'substitute. */
997 gdb::unique_xmalloc_ptr
<gdb_byte
> buffer
;
998 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
999 buffer_contents
= buffer
.release ();
1001 catch (const gdb_exception
&except
)
1004 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1007 /* If errors is "error", scm_from_stringn may throw a Scheme exception.
1008 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1010 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1012 gdbscm_dynwind_xfree (encoding
);
1013 gdbscm_dynwind_xfree (buffer_contents
);
1015 result
= scm_from_stringn ((const char *) buffer_contents
,
1016 length
* TYPE_LENGTH (char_type
),
1017 (encoding
!= NULL
&& *encoding
!= '\0'
1020 scm_is_eq (errors
, error_symbol
)
1021 ? SCM_FAILED_CONVERSION_ERROR
1022 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1029 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1030 -> <gdb:lazy-string>
1031 Return a Scheme object representing a lazy_string_object type.
1032 A lazy string is a pointer to a string with an optional encoding and length.
1033 If ENCODING is not given, the target's charset is used.
1034 If LENGTH is provided then the length parameter is set to LENGTH.
1035 Otherwise if the value is an array of known length then the array's length
1036 is used. Otherwise the length will be set to -1 (meaning first null of
1038 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1041 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1044 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1045 struct value
*value
= v_smob
->value
;
1046 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1047 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1048 char *encoding
= NULL
;
1050 SCM result
= SCM_BOOL_F
; /* -Wall */
1051 struct gdb_exception except
;
1053 /* The sequencing here, as everywhere else, is important.
1054 We can't have existing cleanups when a Scheme exception is thrown. */
1056 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1057 &encoding_arg_pos
, &encoding
,
1058 &length_arg_pos
, &length
);
1062 gdbscm_out_of_range_error (FUNC_NAME
, length_arg_pos
,
1063 scm_from_int (length
),
1064 _("invalid length"));
1069 scoped_value_mark free_values
;
1071 struct type
*type
, *realtype
;
1074 type
= value_type (value
);
1075 realtype
= check_typedef (type
);
1077 switch (TYPE_CODE (realtype
))
1079 case TYPE_CODE_ARRAY
:
1081 LONGEST array_length
= -1;
1082 LONGEST low_bound
, high_bound
;
1084 /* PR 20786: There's no way to specify an array of length zero.
1085 Record a length of [0,-1] which is how Ada does it. Anything
1086 we do is broken, but this one possible solution. */
1087 if (get_array_bounds (realtype
, &low_bound
, &high_bound
))
1088 array_length
= high_bound
- low_bound
+ 1;
1090 length
= array_length
;
1091 else if (array_length
== -1)
1093 type
= lookup_array_range_type (TYPE_TARGET_TYPE (realtype
),
1096 else if (length
!= array_length
)
1098 /* We need to create a new array type with the
1099 specified length. */
1100 if (length
> array_length
)
1101 error (_("length is larger than array size"));
1102 type
= lookup_array_range_type (TYPE_TARGET_TYPE (type
),
1104 low_bound
+ length
- 1);
1106 addr
= value_address (value
);
1110 /* If a length is specified we defer creating an array of the
1111 specified width until we need to. */
1112 addr
= value_as_address (value
);
1115 /* Should flag an error here. PR 20769. */
1116 addr
= value_address (value
);
1120 result
= lsscm_make_lazy_string (addr
, length
, encoding
, type
);
1122 catch (const gdb_exception
&ex
)
1128 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1130 if (gdbscm_is_exception (result
))
1131 gdbscm_throw (result
);
1136 /* (value-lazy? <gdb:value>) -> boolean */
1139 gdbscm_value_lazy_p (SCM self
)
1142 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1143 struct value
*value
= v_smob
->value
;
1145 return scm_from_bool (value_lazy (value
));
1148 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1151 gdbscm_value_fetch_lazy_x (SCM self
)
1154 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1155 struct value
*value
= v_smob
->value
;
1157 return gdbscm_wrap ([=]
1159 if (value_lazy (value
))
1160 value_fetch_lazy (value
);
1161 return SCM_UNSPECIFIED
;
1165 /* (value-print <gdb:value>) -> string */
1168 gdbscm_value_print (SCM self
)
1171 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1172 struct value
*value
= v_smob
->value
;
1173 struct value_print_options opts
;
1175 get_user_print_options (&opts
);
1182 common_val_print (value
, &stb
, 0, &opts
, current_language
);
1184 catch (const gdb_exception
&except
)
1186 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1189 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1190 throw an error if the encoding fails.
1191 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1192 override the default port conversion handler because contrary to
1193 documentation it doesn't necessarily free the input string. */
1194 return scm_from_stringn (stb
.c_str (), stb
.size (), host_charset (),
1195 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1198 /* (parse-and-eval string) -> <gdb:value>
1199 Parse a string and evaluate the string as an expression. */
1202 gdbscm_parse_and_eval (SCM expr_scm
)
1205 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1206 expr_scm
, &expr_str
);
1208 return gdbscm_wrap ([=]
1210 scoped_value_mark free_values
;
1211 return vlscm_scm_from_value (parse_and_eval (expr_str
));
1215 /* (history-ref integer) -> <gdb:value>
1216 Return the specified value from GDB's value history. */
1219 gdbscm_history_ref (SCM index
)
1222 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1224 return gdbscm_wrap ([=]
1226 return vlscm_scm_from_value (access_value_history (i
));
1230 /* (history-append! <gdb:value>) -> index
1231 Append VALUE to GDB's value history. Return its index in the history. */
1234 gdbscm_history_append_x (SCM value
)
1237 = vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1238 return gdbscm_wrap ([=]
1240 return scm_from_int (record_latest_value (v_smob
->value
));
1244 /* Initialize the Scheme value code. */
1246 static const scheme_function value_functions
[] =
1248 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1250 Return #t if the object is a <gdb:value> object." },
1252 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1254 Create a <gdb:value> representing object.\n\
1255 Typically this is used to convert numbers and strings to\n\
1256 <gdb:value> objects.\n\
1258 Arguments: object [#:type <gdb:type>]" },
1260 { "value-optimized-out?", 1, 0, 0,
1261 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1263 Return #t if the value has been optimizd out." },
1265 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1267 Return the address of the value." },
1269 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1271 Return the type of the value." },
1273 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1275 Return the dynamic type of the value." },
1277 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1279 Cast the value to the supplied type.\n\
1281 Arguments: <gdb:value> <gdb:type>" },
1283 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1285 Cast the value to the supplied type, as if by the C++\n\
1286 dynamic_cast operator.\n\
1288 Arguments: <gdb:value> <gdb:type>" },
1290 { "value-reinterpret-cast", 2, 0, 0,
1291 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1293 Cast the value to the supplied type, as if by the C++\n\
1294 reinterpret_cast operator.\n\
1296 Arguments: <gdb:value> <gdb:type>" },
1298 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1300 Return the result of applying the C unary * operator to the value." },
1302 { "value-referenced-value", 1, 0, 0,
1303 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1305 Given a value of a reference type, return the value referenced.\n\
1306 The difference between this function and value-dereference is that\n\
1307 the latter applies * unary operator to a value, which need not always\n\
1308 result in the value referenced.\n\
1309 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1310 value-dereference will result in a value of type 'int' while\n\
1311 value-referenced-value will result in a value of type 'int *'." },
1313 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1315 Return the specified field of the value.\n\
1317 Arguments: <gdb:value> string" },
1319 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1321 Return the value of the array at the specified index.\n\
1323 Arguments: <gdb:value> integer" },
1325 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1327 Perform an inferior function call taking the value as a pointer to the\n\
1328 function to call.\n\
1329 Each element of the argument list must be a <gdb:value> object or an object\n\
1330 that can be converted to one.\n\
1331 The result is the value returned by the function.\n\
1333 Arguments: <gdb:value> arg-list" },
1335 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1337 Return the Scheme boolean representing the GDB value.\n\
1338 The value must be \"integer like\". Pointers are ok." },
1340 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1342 Return the Scheme integer representing the GDB value.\n\
1343 The value must be \"integer like\". Pointers are ok." },
1345 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1347 Return the Scheme real number representing the GDB value.\n\
1348 The value must be a number." },
1350 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1352 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1353 No transformation, endian or otherwise, is performed." },
1355 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1357 Return the Unicode string of the value's contents.\n\
1358 If ENCODING is not given, the string is assumed to be encoded in\n\
1359 the target's charset.\n\
1360 An error setting \"error\" causes an exception to be thrown if there's\n\
1361 a decoding error. An error setting of \"substitute\" causes invalid\n\
1362 characters to be replaced with \"?\". The default is \"error\".\n\
1363 If LENGTH is provided, only fetch string to the length provided.\n\
1365 Arguments: <gdb:value>\n\
1366 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1367 [#:length length]" },
1369 { "value->lazy-string", 1, 0, 1,
1370 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1372 Return a Scheme object representing a lazily fetched Unicode string\n\
1373 of the value's contents.\n\
1374 If ENCODING is not given, the string is assumed to be encoded in\n\
1375 the target's charset.\n\
1376 If LENGTH is provided, only fetch string to the length provided.\n\
1378 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1380 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1382 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1383 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1386 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1388 Create a <gdb:value> that will be lazily fetched from the target.\n\
1390 Arguments: <gdb:type> address" },
1392 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1394 Fetch the value from the inferior, if it was lazy.\n\
1395 The result is \"unspecified\"." },
1397 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1399 Return the string representation (print form) of the value." },
1401 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1403 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1405 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1407 Return the specified value from GDB's value history." },
1409 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1411 Append the specified value onto GDB's value history." },
1417 gdbscm_initialize_values (void)
1419 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1420 sizeof (value_smob
));
1421 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1422 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1423 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1425 gdbscm_define_functions (value_functions
, 1);
1427 type_keyword
= scm_from_latin1_keyword ("type");
1428 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1429 errors_keyword
= scm_from_latin1_keyword ("errors");
1430 length_keyword
= scm_from_latin1_keyword ("length");
1432 error_symbol
= scm_from_latin1_symbol ("error");
1433 escape_symbol
= scm_from_latin1_symbol ("escape");
1434 substitute_symbol
= scm_from_latin1_symbol ("substitute");