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 (except
, RETURN_MASK_ALL
)
168 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
172 if (pstate
->writingp
)
173 scm_puts (">", port
);
175 scm_remember_upto_here_1 (self
);
177 /* Non-zero means success. */
181 /* The smob "equalp" function for <gdb:value>. */
184 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
186 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
187 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
192 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
194 CATCH (except
, RETURN_MASK_ALL
)
196 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
200 return scm_from_bool (result
);
203 /* Low level routine to create a <gdb:value> object. */
206 vlscm_make_value_smob (void)
208 value_smob
*v_smob
= (value_smob
*)
209 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
212 /* These must be filled in by the caller. */
213 v_smob
->value
= NULL
;
217 /* These are lazily computed. */
218 v_smob
->address
= SCM_UNDEFINED
;
219 v_smob
->type
= SCM_UNDEFINED
;
220 v_smob
->dynamic_type
= SCM_UNDEFINED
;
222 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
223 gdbscm_init_gsmob (&v_smob
->base
);
228 /* Return non-zero if SCM is a <gdb:value> object. */
231 vlscm_is_value (SCM scm
)
233 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
236 /* (value? object) -> boolean */
239 gdbscm_value_p (SCM scm
)
241 return scm_from_bool (vlscm_is_value (scm
));
244 /* Create a new <gdb:value> object that encapsulates VALUE.
245 The value is released from the all_values chain so its lifetime is not
246 bound to the execution of a command. */
249 vlscm_scm_from_value (struct value
*value
)
251 /* N.B. It's important to not cause any side-effects until we know the
252 conversion worked. */
253 SCM v_scm
= vlscm_make_value_smob ();
254 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
256 v_smob
->value
= release_value (value
).release ();
257 vlscm_remember_scheme_value (v_smob
);
262 /* Returns the <gdb:value> object in SELF.
263 Throws an exception if SELF is not a <gdb:value> object. */
266 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
268 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
274 /* Returns a pointer to the value smob of SELF.
275 Throws an exception if SELF is not a <gdb:value> object. */
278 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
280 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
281 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
286 /* Return the value field of V_SCM, an object of type <gdb:value>.
287 This exists so that we don't have to export the struct's contents. */
290 vlscm_scm_to_value (SCM v_scm
)
294 gdb_assert (vlscm_is_value (v_scm
));
295 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
296 return v_smob
->value
;
301 /* (make-value x [#:type type]) -> <gdb:value> */
304 gdbscm_make_value (SCM x
, SCM rest
)
306 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
308 int type_arg_pos
= -1;
309 SCM type_scm
= SCM_UNDEFINED
;
310 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
311 &type_arg_pos
, &type_scm
);
313 struct type
*type
= NULL
;
314 if (type_arg_pos
> 0)
316 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
319 type
= tyscm_type_smob_type (t_smob
);
322 return gdbscm_wrap ([=]
324 scoped_value_mark free_values
;
328 = vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
329 type_arg_pos
, type_scm
, type
,
336 return vlscm_scm_from_value (value
);
340 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
343 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
345 type_smob
*t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
,
346 SCM_ARG1
, FUNC_NAME
);
347 struct type
*type
= tyscm_type_smob_type (t_smob
);
350 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
351 address_scm
, &address
);
353 return gdbscm_wrap ([=]
355 scoped_value_mark free_values
;
357 struct value
*value
= value_from_contents_and_address (type
, NULL
,
359 return vlscm_scm_from_value (value
);
363 /* (value-optimized-out? <gdb:value>) -> boolean */
366 gdbscm_value_optimized_out_p (SCM self
)
369 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
371 return gdbscm_wrap ([=]
373 return scm_from_bool (value_optimized_out (v_smob
->value
));
377 /* (value-address <gdb:value>) -> integer
378 Returns #f if the value doesn't have one. */
381 gdbscm_value_address (SCM self
)
384 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
385 struct value
*value
= v_smob
->value
;
387 return gdbscm_wrap ([=]
389 if (SCM_UNBNDP (v_smob
->address
))
391 scoped_value_mark free_values
;
393 SCM address
= SCM_BOOL_F
;
397 address
= vlscm_scm_from_value (value_addr (value
));
399 CATCH (except
, RETURN_MASK_ALL
)
404 if (gdbscm_is_exception (address
))
407 v_smob
->address
= address
;
410 return v_smob
->address
;
414 /* (value-dereference <gdb:value>) -> <gdb:value>
415 Given a value of a pointer type, apply the C unary * operator to it. */
418 gdbscm_value_dereference (SCM self
)
421 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
423 return gdbscm_wrap ([=]
425 scoped_value_mark free_values
;
427 struct value
*res_val
= value_ind (v_smob
->value
);
428 return vlscm_scm_from_value (res_val
);
432 /* (value-referenced-value <gdb:value>) -> <gdb:value>
433 Given a value of a reference type, return the value referenced.
434 The difference between this function and gdbscm_value_dereference is that
435 the latter applies * unary operator to a value, which need not always
436 result in the value referenced.
437 For example, for a value which is a reference to an 'int' pointer ('int *'),
438 gdbscm_value_dereference will result in a value of type 'int' while
439 gdbscm_value_referenced_value will result in a value of type 'int *'. */
442 gdbscm_value_referenced_value (SCM self
)
445 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
446 struct value
*value
= v_smob
->value
;
448 return gdbscm_wrap ([=]
450 scoped_value_mark free_values
;
452 struct value
*res_val
;
454 switch (TYPE_CODE (check_typedef (value_type (value
))))
457 res_val
= value_ind (value
);
460 res_val
= coerce_ref (value
);
463 error (_("Trying to get the referenced value from a value which is"
464 " neither a pointer nor a reference"));
467 return vlscm_scm_from_value (res_val
);
471 /* (value-type <gdb:value>) -> <gdb:type> */
474 gdbscm_value_type (SCM self
)
477 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
478 struct value
*value
= v_smob
->value
;
480 if (SCM_UNBNDP (v_smob
->type
))
481 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
486 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
489 gdbscm_value_dynamic_type (SCM self
)
492 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
493 struct value
*value
= v_smob
->value
;
494 struct type
*type
= NULL
;
496 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
497 return v_smob
->dynamic_type
;
501 scoped_value_mark free_values
;
503 type
= value_type (value
);
504 type
= check_typedef (type
);
506 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
507 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
508 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
510 struct value
*target
;
511 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
514 target
= value_ind (value
);
516 target
= coerce_ref (value
);
517 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
522 type
= lookup_pointer_type (type
);
524 type
= lookup_lvalue_reference_type (type
);
527 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
528 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
531 /* Re-use object's static type. */
535 CATCH (except
, RETURN_MASK_ALL
)
537 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
542 v_smob
->dynamic_type
= gdbscm_value_type (self
);
544 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
546 return v_smob
->dynamic_type
;
549 /* A helper function that implements the various cast operators. */
552 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
553 const char *func_name
)
556 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
557 struct value
*value
= v_smob
->value
;
559 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
560 struct type
*type
= tyscm_type_smob_type (t_smob
);
562 return gdbscm_wrap ([=]
564 scoped_value_mark free_values
;
566 struct value
*res_val
;
567 if (op
== UNOP_DYNAMIC_CAST
)
568 res_val
= value_dynamic_cast (type
, value
);
569 else if (op
== UNOP_REINTERPRET_CAST
)
570 res_val
= value_reinterpret_cast (type
, value
);
573 gdb_assert (op
== UNOP_CAST
);
574 res_val
= value_cast (type
, value
);
577 return vlscm_scm_from_value (res_val
);
581 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
584 gdbscm_value_cast (SCM self
, SCM new_type
)
586 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
589 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
592 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
594 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
597 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
600 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
602 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
605 /* (value-field <gdb:value> string) -> <gdb:value>
606 Given string name of an element inside structure, return its <gdb:value>
610 gdbscm_value_field (SCM self
, SCM field_scm
)
613 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
615 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
618 return gdbscm_wrap ([=]
620 scoped_value_mark free_values
;
622 gdb::unique_xmalloc_ptr
<char> field
= gdbscm_scm_to_c_string (field_scm
);
624 struct value
*tmp
= v_smob
->value
;
626 struct value
*res_val
= value_struct_elt (&tmp
, NULL
, field
.get (), NULL
,
627 "struct/class/union");
629 return vlscm_scm_from_value (res_val
);
633 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
634 Return the specified value in an array. */
637 gdbscm_value_subscript (SCM self
, SCM index_scm
)
640 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
641 struct value
*value
= v_smob
->value
;
642 struct type
*type
= value_type (value
);
644 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
646 return gdbscm_wrap ([=]
648 scoped_value_mark free_values
;
652 = vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
654 get_type_arch (type
),
659 /* Assume we are attempting an array access, and let the value code
660 throw an exception if the index has an invalid type.
661 Check the value's type is something that can be accessed via
663 struct value
*tmp
= coerce_ref (value
);
664 struct type
*tmp_type
= check_typedef (value_type (tmp
));
665 if (TYPE_CODE (tmp_type
) != TYPE_CODE_ARRAY
666 && TYPE_CODE (tmp_type
) != TYPE_CODE_PTR
)
667 error (_("Cannot subscript requested type"));
669 struct value
*res_val
= value_subscript (tmp
, value_as_long (index
));
670 return vlscm_scm_from_value (res_val
);
674 /* (value-call <gdb:value> arg-list) -> <gdb:value>
675 Perform an inferior function call on the value. */
678 gdbscm_value_call (SCM self
, SCM args
)
681 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
682 struct value
*function
= v_smob
->value
;
683 struct type
*ftype
= NULL
;
685 struct value
**vargs
= NULL
;
689 ftype
= check_typedef (value_type (function
));
691 CATCH (except
, RETURN_MASK_ALL
)
693 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
697 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
699 _("function (value of TYPE_CODE_FUNC)"));
701 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
702 SCM_ARG2
, FUNC_NAME
, _("list"));
704 args_count
= scm_ilength (args
);
707 struct gdbarch
*gdbarch
= get_current_arch ();
708 const struct language_defn
*language
= current_language
;
712 vargs
= XALLOCAVEC (struct value
*, args_count
);
713 for (i
= 0; i
< args_count
; i
++)
715 SCM arg
= scm_car (args
);
717 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
718 GDBSCM_ARG_NONE
, arg
,
721 if (vargs
[i
] == NULL
)
722 gdbscm_throw (except_scm
);
724 args
= scm_cdr (args
);
726 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
729 return gdbscm_wrap ([=]
731 scoped_value_mark free_values
;
733 auto av
= gdb::make_array_view (vargs
, args_count
);
734 value
*return_value
= call_function_by_hand (function
, NULL
, av
);
735 return vlscm_scm_from_value (return_value
);
739 /* (value->bytevector <gdb:value>) -> bytevector */
742 gdbscm_value_to_bytevector (SCM self
)
745 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
746 struct value
*value
= v_smob
->value
;
749 const gdb_byte
*contents
= NULL
;
752 type
= value_type (value
);
756 type
= check_typedef (type
);
757 length
= TYPE_LENGTH (type
);
758 contents
= value_contents (value
);
760 CATCH (except
, RETURN_MASK_ALL
)
762 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
766 bv
= scm_c_make_bytevector (length
);
767 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
772 /* Helper function to determine if a type is "int-like". */
775 is_intlike (struct type
*type
, int ptr_ok
)
777 return (TYPE_CODE (type
) == TYPE_CODE_INT
778 || TYPE_CODE (type
) == TYPE_CODE_ENUM
779 || TYPE_CODE (type
) == TYPE_CODE_BOOL
780 || TYPE_CODE (type
) == TYPE_CODE_CHAR
781 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
784 /* (value->bool <gdb:value>) -> boolean
785 Throws an error if the value is not integer-like. */
788 gdbscm_value_to_bool (SCM self
)
791 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
792 struct value
*value
= v_smob
->value
;
796 type
= value_type (value
);
800 type
= check_typedef (type
);
802 CATCH (except
, RETURN_MASK_ALL
)
804 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
808 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
809 _("integer-like gdb value"));
813 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
814 l
= value_as_address (value
);
816 l
= value_as_long (value
);
818 CATCH (except
, RETURN_MASK_ALL
)
820 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
824 return scm_from_bool (l
!= 0);
827 /* (value->integer <gdb:value>) -> integer
828 Throws an error if the value is not integer-like. */
831 gdbscm_value_to_integer (SCM self
)
834 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
835 struct value
*value
= v_smob
->value
;
839 type
= value_type (value
);
843 type
= check_typedef (type
);
845 CATCH (except
, RETURN_MASK_ALL
)
847 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
851 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
852 _("integer-like gdb value"));
856 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
857 l
= value_as_address (value
);
859 l
= value_as_long (value
);
861 CATCH (except
, RETURN_MASK_ALL
)
863 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
867 if (TYPE_UNSIGNED (type
))
868 return gdbscm_scm_from_ulongest (l
);
870 return gdbscm_scm_from_longest (l
);
873 /* (value->real <gdb:value>) -> real
874 Throws an error if the value is not a number. */
877 gdbscm_value_to_real (SCM self
)
880 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
881 struct value
*value
= v_smob
->value
;
884 struct value
*check
= nullptr;
886 type
= value_type (value
);
890 type
= check_typedef (type
);
892 CATCH (except
, RETURN_MASK_ALL
)
894 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
898 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
899 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
903 if (is_floating_value (value
))
905 d
= target_float_to_host_double (value_contents (value
), type
);
906 check
= allocate_value (type
);
907 target_float_from_host_double (value_contents_raw (check
), type
, d
);
909 else if (TYPE_UNSIGNED (type
))
911 d
= (ULONGEST
) value_as_long (value
);
912 check
= value_from_ulongest (type
, (ULONGEST
) d
);
916 d
= value_as_long (value
);
917 check
= value_from_longest (type
, (LONGEST
) d
);
920 CATCH (except
, RETURN_MASK_ALL
)
922 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
926 /* TODO: Is there a better way to check if the value fits? */
927 if (!value_equal (value
, check
))
928 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
929 _("number can't be converted to a double"));
931 return scm_from_double (d
);
934 /* (value->string <gdb:value>
935 [#:encoding encoding]
936 [#:errors #f | 'error | 'substitute]
939 Return Unicode string with value's contents, which must be a string.
941 If ENCODING is not given, the string is assumed to be encoded in
942 the target's charset.
944 ERRORS is one of #f, 'error or 'substitute.
945 An error setting of #f means use the default, which is Guile's
946 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
947 using an earlier version of Guile. Earlier versions do not properly
948 support obtaining the default port conversion strategy.
949 If the default is not one of 'error or 'substitute, 'substitute is used.
950 An error setting of "error" causes an exception to be thrown if there's
951 a decoding error. An error setting of "substitute" causes invalid
952 characters to be replaced with "?".
954 If LENGTH is provided, only fetch string to the length provided.
955 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
958 gdbscm_value_to_string (SCM self
, SCM rest
)
961 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
962 struct value
*value
= v_smob
->value
;
963 const SCM keywords
[] = {
964 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
966 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
967 char *encoding
= NULL
;
968 SCM errors
= SCM_BOOL_F
;
969 /* Avoid an uninitialized warning from gcc. */
970 gdb_byte
*buffer_contents
= nullptr;
972 const char *la_encoding
= NULL
;
973 struct type
*char_type
= NULL
;
976 /* The sequencing here, as everywhere else, is important.
977 We can't have existing cleanups when a Scheme exception is thrown. */
979 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
980 &encoding_arg_pos
, &encoding
,
981 &errors_arg_pos
, &errors
,
982 &length_arg_pos
, &length
);
984 if (errors_arg_pos
> 0
985 && errors
!= SCM_BOOL_F
986 && !scm_is_eq (errors
, error_symbol
)
987 && !scm_is_eq (errors
, substitute_symbol
))
990 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
991 _("invalid error kind"));
996 if (errors
== SCM_BOOL_F
)
998 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
999 will throw a Scheme error when passed #f. */
1000 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1001 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1003 errors
= error_symbol
;
1005 /* We don't assume anything about the result of scm_port_conversion_strategy.
1006 From this point on, if errors is not 'errors, use 'substitute. */
1010 gdb::unique_xmalloc_ptr
<gdb_byte
> buffer
;
1011 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1012 buffer_contents
= buffer
.release ();
1014 CATCH (except
, RETURN_MASK_ALL
)
1017 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1021 /* If errors is "error", scm_from_stringn may throw a Scheme exception.
1022 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1024 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1026 gdbscm_dynwind_xfree (encoding
);
1027 gdbscm_dynwind_xfree (buffer_contents
);
1029 result
= scm_from_stringn ((const char *) buffer_contents
,
1030 length
* TYPE_LENGTH (char_type
),
1031 (encoding
!= NULL
&& *encoding
!= '\0'
1034 scm_is_eq (errors
, error_symbol
)
1035 ? SCM_FAILED_CONVERSION_ERROR
1036 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1043 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1044 -> <gdb:lazy-string>
1045 Return a Scheme object representing a lazy_string_object type.
1046 A lazy string is a pointer to a string with an optional encoding and length.
1047 If ENCODING is not given, the target's charset is used.
1048 If LENGTH is provided then the length parameter is set to LENGTH.
1049 Otherwise if the value is an array of known length then the array's length
1050 is used. Otherwise the length will be set to -1 (meaning first null of
1052 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1055 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1058 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1059 struct value
*value
= v_smob
->value
;
1060 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1061 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1062 char *encoding
= NULL
;
1064 SCM result
= SCM_BOOL_F
; /* -Wall */
1065 struct gdb_exception except
= exception_none
;
1067 /* The sequencing here, as everywhere else, is important.
1068 We can't have existing cleanups when a Scheme exception is thrown. */
1070 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1071 &encoding_arg_pos
, &encoding
,
1072 &length_arg_pos
, &length
);
1076 gdbscm_out_of_range_error (FUNC_NAME
, length_arg_pos
,
1077 scm_from_int (length
),
1078 _("invalid length"));
1083 scoped_value_mark free_values
;
1085 struct type
*type
, *realtype
;
1088 type
= value_type (value
);
1089 realtype
= check_typedef (type
);
1091 switch (TYPE_CODE (realtype
))
1093 case TYPE_CODE_ARRAY
:
1095 LONGEST array_length
= -1;
1096 LONGEST low_bound
, high_bound
;
1098 /* PR 20786: There's no way to specify an array of length zero.
1099 Record a length of [0,-1] which is how Ada does it. Anything
1100 we do is broken, but this one possible solution. */
1101 if (get_array_bounds (realtype
, &low_bound
, &high_bound
))
1102 array_length
= high_bound
- low_bound
+ 1;
1104 length
= array_length
;
1105 else if (array_length
== -1)
1107 type
= lookup_array_range_type (TYPE_TARGET_TYPE (realtype
),
1110 else if (length
!= array_length
)
1112 /* We need to create a new array type with the
1113 specified length. */
1114 if (length
> array_length
)
1115 error (_("length is larger than array size"));
1116 type
= lookup_array_range_type (TYPE_TARGET_TYPE (type
),
1118 low_bound
+ length
- 1);
1120 addr
= value_address (value
);
1124 /* If a length is specified we defer creating an array of the
1125 specified width until we need to. */
1126 addr
= value_as_address (value
);
1129 /* Should flag an error here. PR 20769. */
1130 addr
= value_address (value
);
1134 result
= lsscm_make_lazy_string (addr
, length
, encoding
, type
);
1136 CATCH (ex
, RETURN_MASK_ALL
)
1143 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1145 if (gdbscm_is_exception (result
))
1146 gdbscm_throw (result
);
1151 /* (value-lazy? <gdb:value>) -> boolean */
1154 gdbscm_value_lazy_p (SCM self
)
1157 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1158 struct value
*value
= v_smob
->value
;
1160 return scm_from_bool (value_lazy (value
));
1163 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1166 gdbscm_value_fetch_lazy_x (SCM self
)
1169 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1170 struct value
*value
= v_smob
->value
;
1172 return gdbscm_wrap ([=]
1174 if (value_lazy (value
))
1175 value_fetch_lazy (value
);
1176 return SCM_UNSPECIFIED
;
1180 /* (value-print <gdb:value>) -> string */
1183 gdbscm_value_print (SCM self
)
1186 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1187 struct value
*value
= v_smob
->value
;
1188 struct value_print_options opts
;
1190 get_user_print_options (&opts
);
1197 common_val_print (value
, &stb
, 0, &opts
, current_language
);
1199 CATCH (except
, RETURN_MASK_ALL
)
1201 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1205 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1206 throw an error if the encoding fails.
1207 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1208 override the default port conversion handler because contrary to
1209 documentation it doesn't necessarily free the input string. */
1210 return scm_from_stringn (stb
.c_str (), stb
.size (), host_charset (),
1211 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1214 /* (parse-and-eval string) -> <gdb:value>
1215 Parse a string and evaluate the string as an expression. */
1218 gdbscm_parse_and_eval (SCM expr_scm
)
1221 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1222 expr_scm
, &expr_str
);
1224 return gdbscm_wrap ([=]
1226 scoped_value_mark free_values
;
1227 return vlscm_scm_from_value (parse_and_eval (expr_str
));
1231 /* (history-ref integer) -> <gdb:value>
1232 Return the specified value from GDB's value history. */
1235 gdbscm_history_ref (SCM index
)
1238 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1240 return gdbscm_wrap ([=]
1242 return vlscm_scm_from_value (access_value_history (i
));
1246 /* (history-append! <gdb:value>) -> index
1247 Append VALUE to GDB's value history. Return its index in the history. */
1250 gdbscm_history_append_x (SCM value
)
1253 = vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1254 return gdbscm_wrap ([=]
1256 return scm_from_int (record_latest_value (v_smob
->value
));
1260 /* Initialize the Scheme value code. */
1262 static const scheme_function value_functions
[] =
1264 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1266 Return #t if the object is a <gdb:value> object." },
1268 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1270 Create a <gdb:value> representing object.\n\
1271 Typically this is used to convert numbers and strings to\n\
1272 <gdb:value> objects.\n\
1274 Arguments: object [#:type <gdb:type>]" },
1276 { "value-optimized-out?", 1, 0, 0,
1277 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1279 Return #t if the value has been optimizd out." },
1281 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1283 Return the address of the value." },
1285 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1287 Return the type of the value." },
1289 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1291 Return the dynamic type of the value." },
1293 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1295 Cast the value to the supplied type.\n\
1297 Arguments: <gdb:value> <gdb:type>" },
1299 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1301 Cast the value to the supplied type, as if by the C++\n\
1302 dynamic_cast operator.\n\
1304 Arguments: <gdb:value> <gdb:type>" },
1306 { "value-reinterpret-cast", 2, 0, 0,
1307 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1309 Cast the value to the supplied type, as if by the C++\n\
1310 reinterpret_cast operator.\n\
1312 Arguments: <gdb:value> <gdb:type>" },
1314 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1316 Return the result of applying the C unary * operator to the value." },
1318 { "value-referenced-value", 1, 0, 0,
1319 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1321 Given a value of a reference type, return the value referenced.\n\
1322 The difference between this function and value-dereference is that\n\
1323 the latter applies * unary operator to a value, which need not always\n\
1324 result in the value referenced.\n\
1325 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1326 value-dereference will result in a value of type 'int' while\n\
1327 value-referenced-value will result in a value of type 'int *'." },
1329 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1331 Return the specified field of the value.\n\
1333 Arguments: <gdb:value> string" },
1335 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1337 Return the value of the array at the specified index.\n\
1339 Arguments: <gdb:value> integer" },
1341 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1343 Perform an inferior function call taking the value as a pointer to the\n\
1344 function to call.\n\
1345 Each element of the argument list must be a <gdb:value> object or an object\n\
1346 that can be converted to one.\n\
1347 The result is the value returned by the function.\n\
1349 Arguments: <gdb:value> arg-list" },
1351 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1353 Return the Scheme boolean representing the GDB value.\n\
1354 The value must be \"integer like\". Pointers are ok." },
1356 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1358 Return the Scheme integer representing the GDB value.\n\
1359 The value must be \"integer like\". Pointers are ok." },
1361 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1363 Return the Scheme real number representing the GDB value.\n\
1364 The value must be a number." },
1366 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1368 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1369 No transformation, endian or otherwise, is performed." },
1371 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1373 Return the Unicode string 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 An error setting \"error\" causes an exception to be thrown if there's\n\
1377 a decoding error. An error setting of \"substitute\" causes invalid\n\
1378 characters to be replaced with \"?\". The default is \"error\".\n\
1379 If LENGTH is provided, only fetch string to the length provided.\n\
1381 Arguments: <gdb:value>\n\
1382 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1383 [#:length length]" },
1385 { "value->lazy-string", 1, 0, 1,
1386 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1388 Return a Scheme object representing a lazily fetched Unicode string\n\
1389 of the value's contents.\n\
1390 If ENCODING is not given, the string is assumed to be encoded in\n\
1391 the target's charset.\n\
1392 If LENGTH is provided, only fetch string to the length provided.\n\
1394 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1396 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1398 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1399 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1402 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1404 Create a <gdb:value> that will be lazily fetched from the target.\n\
1406 Arguments: <gdb:type> address" },
1408 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1410 Fetch the value from the inferior, if it was lazy.\n\
1411 The result is \"unspecified\"." },
1413 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1415 Return the string representation (print form) of the value." },
1417 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1419 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1421 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1423 Return the specified value from GDB's value history." },
1425 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1427 Append the specified value onto GDB's value history." },
1433 gdbscm_initialize_values (void)
1435 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1436 sizeof (value_smob
));
1437 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1438 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1439 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1441 gdbscm_define_functions (value_functions
, 1);
1443 type_keyword
= scm_from_latin1_keyword ("type");
1444 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1445 errors_keyword
= scm_from_latin1_keyword ("errors");
1446 length_keyword
= scm_from_latin1_keyword ("length");
1448 error_symbol
= scm_from_latin1_symbol ("error");
1449 escape_symbol
= scm_from_latin1_symbol ("escape");
1450 substitute_symbol
= scm_from_latin1_symbol ("substitute");