1 /* Scheme interface to values.
3 Copyright (C) 2008-2017 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
24 #include "arch-utils.h"
28 #include "symtab.h" /* Needed by language.h. */
32 #include "guile-internal.h"
34 /* The <gdb:value> smob. */
36 typedef struct _value_smob
38 /* This always appears first. */
41 /* Doubly linked list of values in values_in_scheme.
42 IWBN to use a chained_gdb_smob instead, which is doable, it just requires
43 a bit more casting than normal. */
44 struct _value_smob
*next
;
45 struct _value_smob
*prev
;
49 /* These are cached here to avoid making multiple copies of them.
50 Plus computing the dynamic_type can be a bit expensive.
51 We use #f to indicate that the value doesn't exist (e.g. value doesn't
52 have an address), so we need another value to indicate that we haven't
53 computed the value yet. For this we use SCM_UNDEFINED. */
59 static const char value_smob_name
[] = "gdb:value";
61 /* The tag Guile knows the value smob by. */
62 static scm_t_bits value_smob_tag
;
64 /* List of all values which are currently exposed to Scheme. It is
65 maintained so that when an objfile is discarded, preserve_values
66 can copy the values' types if needed. */
67 static value_smob
*values_in_scheme
;
69 /* Keywords used by Scheme procedures in this file. */
70 static SCM type_keyword
;
71 static SCM encoding_keyword
;
72 static SCM errors_keyword
;
73 static SCM length_keyword
;
75 /* Possible #:errors values. */
76 static SCM error_symbol
;
77 static SCM escape_symbol
;
78 static SCM substitute_symbol
;
80 /* Administrivia for value smobs. */
82 /* Iterate over all the <gdb:value> objects, calling preserve_one_value on
84 This is the extension_language_ops.preserve_values "method". */
87 gdbscm_preserve_values (const struct extension_language_defn
*extlang
,
88 struct objfile
*objfile
, htab_t copied_types
)
92 for (iter
= values_in_scheme
; iter
; iter
= iter
->next
)
93 preserve_one_value (iter
->value
, objfile
, copied_types
);
96 /* Helper to add a value_smob to the global list. */
99 vlscm_remember_scheme_value (value_smob
*v_smob
)
101 v_smob
->next
= values_in_scheme
;
103 v_smob
->next
->prev
= v_smob
;
105 values_in_scheme
= v_smob
;
108 /* Helper to remove a value_smob from the global list. */
111 vlscm_forget_value_smob (value_smob
*v_smob
)
113 /* Remove SELF from the global list. */
115 v_smob
->prev
->next
= v_smob
->next
;
118 gdb_assert (values_in_scheme
== v_smob
);
119 values_in_scheme
= v_smob
->next
;
122 v_smob
->next
->prev
= v_smob
->prev
;
125 /* The smob "free" function for <gdb:value>. */
128 vlscm_free_value_smob (SCM self
)
130 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
132 vlscm_forget_value_smob (v_smob
);
133 value_free (v_smob
->value
);
138 /* The smob "print" function for <gdb:value>. */
141 vlscm_print_value_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
143 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
144 struct value_print_options opts
;
146 if (pstate
->writingp
)
147 gdbscm_printf (port
, "#<%s ", value_smob_name
);
149 get_user_print_options (&opts
);
152 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
153 invoked by write/~S. What to do here may need to evolve.
154 IWBN if we could pass an argument to format that would we could use
155 instead of writingp. */
156 opts
.raw
= !!pstate
->writingp
;
162 common_val_print (v_smob
->value
, &stb
, 0, &opts
, current_language
);
163 scm_puts (stb
.c_str (), port
);
165 CATCH (except
, RETURN_MASK_ALL
)
167 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 (except
, RETURN_MASK_ALL
)
195 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
199 return scm_from_bool (result
);
202 /* Low level routine to create a <gdb:value> object. */
205 vlscm_make_value_smob (void)
207 value_smob
*v_smob
= (value_smob
*)
208 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
211 /* These must be filled in by the caller. */
212 v_smob
->value
= NULL
;
216 /* These are lazily computed. */
217 v_smob
->address
= SCM_UNDEFINED
;
218 v_smob
->type
= SCM_UNDEFINED
;
219 v_smob
->dynamic_type
= SCM_UNDEFINED
;
221 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
222 gdbscm_init_gsmob (&v_smob
->base
);
227 /* Return non-zero if SCM is a <gdb:value> object. */
230 vlscm_is_value (SCM scm
)
232 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
235 /* (value? object) -> boolean */
238 gdbscm_value_p (SCM scm
)
240 return scm_from_bool (vlscm_is_value (scm
));
243 /* Create a new <gdb:value> object that encapsulates VALUE.
244 The value is released from the all_values chain so its lifetime is not
245 bound to the execution of a command. */
248 vlscm_scm_from_value (struct value
*value
)
250 /* N.B. It's important to not cause any side-effects until we know the
251 conversion worked. */
252 SCM v_scm
= vlscm_make_value_smob ();
253 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
255 v_smob
->value
= value
;
256 release_value_or_incref (value
);
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 struct gdbarch
*gdbarch
= get_current_arch ();
307 const struct language_defn
*language
= current_language
;
308 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
309 int type_arg_pos
= -1;
310 SCM type_scm
= SCM_UNDEFINED
;
311 SCM except_scm
, result
;
313 struct type
*type
= NULL
;
315 struct cleanup
*cleanups
;
317 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
318 &type_arg_pos
, &type_scm
);
320 if (type_arg_pos
> 0)
322 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, type_arg_pos
,
324 type
= tyscm_type_smob_type (t_smob
);
327 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
329 value
= vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
330 type_arg_pos
, type_scm
, type
,
335 do_cleanups (cleanups
);
336 gdbscm_throw (except_scm
);
339 result
= vlscm_scm_from_value (value
);
341 do_cleanups (cleanups
);
343 if (gdbscm_is_exception (result
))
344 gdbscm_throw (result
);
348 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
351 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
356 struct value
*value
= NULL
;
358 struct cleanup
*cleanups
;
360 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG1
, FUNC_NAME
);
361 type
= tyscm_type_smob_type (t_smob
);
363 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
364 address_scm
, &address
);
366 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
368 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
369 and future-proofing we do. */
372 value
= value_from_contents_and_address (type
, NULL
, address
);
374 CATCH (except
, RETURN_MASK_ALL
)
376 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
380 result
= vlscm_scm_from_value (value
);
382 do_cleanups (cleanups
);
384 if (gdbscm_is_exception (result
))
385 gdbscm_throw (result
);
389 /* (value-optimized-out? <gdb:value>) -> boolean */
392 gdbscm_value_optimized_out_p (SCM self
)
395 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
396 struct value
*value
= v_smob
->value
;
401 opt
= value_optimized_out (value
);
403 CATCH (except
, RETURN_MASK_ALL
)
405 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
409 return scm_from_bool (opt
);
412 /* (value-address <gdb:value>) -> integer
413 Returns #f if the value doesn't have one. */
416 gdbscm_value_address (SCM self
)
419 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
420 struct value
*value
= v_smob
->value
;
422 if (SCM_UNBNDP (v_smob
->address
))
424 struct value
*res_val
= NULL
;
425 struct cleanup
*cleanup
426 = make_cleanup_value_free_to_mark (value_mark ());
431 res_val
= value_addr (value
);
433 CATCH (except
, RETURN_MASK_ALL
)
435 address
= SCM_BOOL_F
;
440 address
= vlscm_scm_from_value (res_val
);
442 do_cleanups (cleanup
);
444 if (gdbscm_is_exception (address
))
445 gdbscm_throw (address
);
447 v_smob
->address
= address
;
450 return v_smob
->address
;
453 /* (value-dereference <gdb:value>) -> <gdb:value>
454 Given a value of a pointer type, apply the C unary * operator to it. */
457 gdbscm_value_dereference (SCM self
)
460 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
461 struct value
*value
= v_smob
->value
;
463 struct value
*res_val
= NULL
;
464 struct cleanup
*cleanups
;
466 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
470 res_val
= value_ind (value
);
472 CATCH (except
, RETURN_MASK_ALL
)
474 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
478 result
= vlscm_scm_from_value (res_val
);
480 do_cleanups (cleanups
);
482 if (gdbscm_is_exception (result
))
483 gdbscm_throw (result
);
488 /* (value-referenced-value <gdb:value>) -> <gdb:value>
489 Given a value of a reference type, return the value referenced.
490 The difference between this function and gdbscm_value_dereference is that
491 the latter applies * unary operator to a value, which need not always
492 result in the value referenced.
493 For example, for a value which is a reference to an 'int' pointer ('int *'),
494 gdbscm_value_dereference will result in a value of type 'int' while
495 gdbscm_value_referenced_value will result in a value of type 'int *'. */
498 gdbscm_value_referenced_value (SCM self
)
501 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
502 struct value
*value
= v_smob
->value
;
504 struct value
*res_val
= NULL
;
505 struct cleanup
*cleanups
;
507 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
511 switch (TYPE_CODE (check_typedef (value_type (value
))))
514 res_val
= value_ind (value
);
517 res_val
= coerce_ref (value
);
520 error (_("Trying to get the referenced value from a value which is"
521 " neither a pointer nor a reference"));
524 CATCH (except
, RETURN_MASK_ALL
)
526 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
530 result
= vlscm_scm_from_value (res_val
);
532 do_cleanups (cleanups
);
534 if (gdbscm_is_exception (result
))
535 gdbscm_throw (result
);
540 /* (value-type <gdb:value>) -> <gdb:type> */
543 gdbscm_value_type (SCM self
)
546 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
547 struct value
*value
= v_smob
->value
;
549 if (SCM_UNBNDP (v_smob
->type
))
550 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
555 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
558 gdbscm_value_dynamic_type (SCM self
)
561 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
562 struct value
*value
= v_smob
->value
;
563 struct type
*type
= NULL
;
565 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
566 return v_smob
->dynamic_type
;
570 struct cleanup
*cleanup
571 = make_cleanup_value_free_to_mark (value_mark ());
573 type
= value_type (value
);
574 type
= check_typedef (type
);
576 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
577 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
578 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
580 struct value
*target
;
581 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
584 target
= value_ind (value
);
586 target
= coerce_ref (value
);
587 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
592 type
= lookup_pointer_type (type
);
594 type
= lookup_lvalue_reference_type (type
);
597 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
598 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
601 /* Re-use object's static type. */
605 do_cleanups (cleanup
);
607 CATCH (except
, RETURN_MASK_ALL
)
609 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
614 v_smob
->dynamic_type
= gdbscm_value_type (self
);
616 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
618 return v_smob
->dynamic_type
;
621 /* A helper function that implements the various cast operators. */
624 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
625 const char *func_name
)
628 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
629 struct value
*value
= v_smob
->value
;
631 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
632 struct type
*type
= tyscm_type_smob_type (t_smob
);
634 struct value
*res_val
= NULL
;
635 struct cleanup
*cleanups
;
637 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
641 if (op
== UNOP_DYNAMIC_CAST
)
642 res_val
= value_dynamic_cast (type
, value
);
643 else if (op
== UNOP_REINTERPRET_CAST
)
644 res_val
= value_reinterpret_cast (type
, value
);
647 gdb_assert (op
== UNOP_CAST
);
648 res_val
= value_cast (type
, value
);
651 CATCH (except
, RETURN_MASK_ALL
)
653 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
657 gdb_assert (res_val
!= NULL
);
658 result
= vlscm_scm_from_value (res_val
);
660 do_cleanups (cleanups
);
662 if (gdbscm_is_exception (result
))
663 gdbscm_throw (result
);
668 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
671 gdbscm_value_cast (SCM self
, SCM new_type
)
673 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
676 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
679 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
681 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
684 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
687 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
689 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
692 /* (value-field <gdb:value> string) -> <gdb:value>
693 Given string name of an element inside structure, return its <gdb:value>
697 gdbscm_value_field (SCM self
, SCM field_scm
)
700 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
701 struct value
*value
= v_smob
->value
;
703 struct value
*res_val
= NULL
;
705 struct cleanup
*cleanups
;
707 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
710 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
712 field
= gdbscm_scm_to_c_string (field_scm
);
713 make_cleanup (xfree
, field
);
717 struct value
*tmp
= value
;
719 res_val
= value_struct_elt (&tmp
, NULL
, field
, NULL
,
720 "struct/class/union");
722 CATCH (except
, RETURN_MASK_ALL
)
724 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
728 gdb_assert (res_val
!= NULL
);
729 result
= vlscm_scm_from_value (res_val
);
731 do_cleanups (cleanups
);
733 if (gdbscm_is_exception (result
))
734 gdbscm_throw (result
);
739 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
740 Return the specified value in an array. */
743 gdbscm_value_subscript (SCM self
, SCM index_scm
)
746 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
747 struct value
*value
= v_smob
->value
;
748 struct value
*index
= NULL
;
749 struct value
*res_val
= NULL
;
750 struct type
*type
= value_type (value
);
751 struct gdbarch
*gdbarch
;
752 SCM result
, except_scm
;
753 struct cleanup
*cleanups
;
755 /* The sequencing here, as everywhere else, is important.
756 We can't have existing cleanups when a Scheme exception is thrown. */
758 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
759 gdbarch
= get_type_arch (type
);
761 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
763 index
= vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
765 gdbarch
, current_language
);
768 do_cleanups (cleanups
);
769 gdbscm_throw (except_scm
);
774 struct value
*tmp
= value
;
776 /* Assume we are attempting an array access, and let the value code
777 throw an exception if the index has an invalid type.
778 Check the value's type is something that can be accessed via
780 tmp
= coerce_ref (tmp
);
781 type
= check_typedef (value_type (tmp
));
782 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
783 && TYPE_CODE (type
) != TYPE_CODE_PTR
)
784 error (_("Cannot subscript requested type"));
786 res_val
= value_subscript (tmp
, value_as_long (index
));
788 CATCH (except
, RETURN_MASK_ALL
)
790 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
794 gdb_assert (res_val
!= NULL
);
795 result
= vlscm_scm_from_value (res_val
);
797 do_cleanups (cleanups
);
799 if (gdbscm_is_exception (result
))
800 gdbscm_throw (result
);
805 /* (value-call <gdb:value> arg-list) -> <gdb:value>
806 Perform an inferior function call on the value. */
809 gdbscm_value_call (SCM self
, SCM args
)
812 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
813 struct value
*function
= v_smob
->value
;
814 struct value
*mark
= value_mark ();
815 struct type
*ftype
= NULL
;
817 struct value
**vargs
= NULL
;
818 SCM result
= SCM_BOOL_F
;
822 ftype
= check_typedef (value_type (function
));
824 CATCH (except
, RETURN_MASK_ALL
)
826 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
830 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
832 _("function (value of TYPE_CODE_FUNC)"));
834 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
835 SCM_ARG2
, FUNC_NAME
, _("list"));
837 args_count
= scm_ilength (args
);
840 struct gdbarch
*gdbarch
= get_current_arch ();
841 const struct language_defn
*language
= current_language
;
845 vargs
= XALLOCAVEC (struct value
*, args_count
);
846 for (i
= 0; i
< args_count
; i
++)
848 SCM arg
= scm_car (args
);
850 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
851 GDBSCM_ARG_NONE
, arg
,
854 if (vargs
[i
] == NULL
)
855 gdbscm_throw (except_scm
);
857 args
= scm_cdr (args
);
859 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
864 struct cleanup
*cleanup
= make_cleanup_value_free_to_mark (mark
);
865 struct value
*return_value
;
867 return_value
= call_function_by_hand (function
, args_count
, vargs
);
868 result
= vlscm_scm_from_value (return_value
);
869 do_cleanups (cleanup
);
871 CATCH (except
, RETURN_MASK_ALL
)
873 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
877 if (gdbscm_is_exception (result
))
878 gdbscm_throw (result
);
883 /* (value->bytevector <gdb:value>) -> bytevector */
886 gdbscm_value_to_bytevector (SCM self
)
889 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
890 struct value
*value
= v_smob
->value
;
893 const gdb_byte
*contents
= NULL
;
896 type
= value_type (value
);
900 type
= check_typedef (type
);
901 length
= TYPE_LENGTH (type
);
902 contents
= value_contents (value
);
904 CATCH (except
, RETURN_MASK_ALL
)
906 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
910 bv
= scm_c_make_bytevector (length
);
911 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
916 /* Helper function to determine if a type is "int-like". */
919 is_intlike (struct type
*type
, int ptr_ok
)
921 return (TYPE_CODE (type
) == TYPE_CODE_INT
922 || TYPE_CODE (type
) == TYPE_CODE_ENUM
923 || TYPE_CODE (type
) == TYPE_CODE_BOOL
924 || TYPE_CODE (type
) == TYPE_CODE_CHAR
925 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
928 /* (value->bool <gdb:value>) -> boolean
929 Throws an error if the value is not integer-like. */
932 gdbscm_value_to_bool (SCM self
)
935 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
936 struct value
*value
= v_smob
->value
;
940 type
= value_type (value
);
944 type
= check_typedef (type
);
946 CATCH (except
, RETURN_MASK_ALL
)
948 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
952 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
953 _("integer-like gdb value"));
957 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
958 l
= value_as_address (value
);
960 l
= value_as_long (value
);
962 CATCH (except
, RETURN_MASK_ALL
)
964 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
968 return scm_from_bool (l
!= 0);
971 /* (value->integer <gdb:value>) -> integer
972 Throws an error if the value is not integer-like. */
975 gdbscm_value_to_integer (SCM self
)
978 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
979 struct value
*value
= v_smob
->value
;
983 type
= value_type (value
);
987 type
= check_typedef (type
);
989 CATCH (except
, RETURN_MASK_ALL
)
991 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
995 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
996 _("integer-like gdb value"));
1000 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1001 l
= value_as_address (value
);
1003 l
= value_as_long (value
);
1005 CATCH (except
, RETURN_MASK_ALL
)
1007 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1011 if (TYPE_UNSIGNED (type
))
1012 return gdbscm_scm_from_ulongest (l
);
1014 return gdbscm_scm_from_longest (l
);
1017 /* (value->real <gdb:value>) -> real
1018 Throws an error if the value is not a number. */
1021 gdbscm_value_to_real (SCM self
)
1024 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1025 struct value
*value
= v_smob
->value
;
1029 type
= value_type (value
);
1033 type
= check_typedef (type
);
1035 CATCH (except
, RETURN_MASK_ALL
)
1037 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1041 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
1042 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
1046 d
= value_as_double (value
);
1048 CATCH (except
, RETURN_MASK_ALL
)
1050 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1054 /* TODO: Is there a better way to check if the value fits? */
1055 if (d
!= (double) d
)
1056 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1057 _("number can't be converted to a double"));
1059 return scm_from_double (d
);
1062 /* (value->string <gdb:value>
1063 [#:encoding encoding]
1064 [#:errors #f | 'error | 'substitute]
1067 Return Unicode string with value's contents, which must be a string.
1069 If ENCODING is not given, the string is assumed to be encoded in
1070 the target's charset.
1072 ERRORS is one of #f, 'error or 'substitute.
1073 An error setting of #f means use the default, which is Guile's
1074 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1075 using an earlier version of Guile. Earlier versions do not properly
1076 support obtaining the default port conversion strategy.
1077 If the default is not one of 'error or 'substitute, 'substitute is used.
1078 An error setting of "error" causes an exception to be thrown if there's
1079 a decoding error. An error setting of "substitute" causes invalid
1080 characters to be replaced with "?".
1082 If LENGTH is provided, only fetch string to the length provided.
1083 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1086 gdbscm_value_to_string (SCM self
, SCM rest
)
1089 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1090 struct value
*value
= v_smob
->value
;
1091 const SCM keywords
[] = {
1092 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
1094 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
1095 char *encoding
= NULL
;
1096 SCM errors
= SCM_BOOL_F
;
1098 gdb_byte
*buffer
= NULL
;
1099 const char *la_encoding
= NULL
;
1100 struct type
*char_type
= NULL
;
1102 struct cleanup
*cleanups
;
1104 /* The sequencing here, as everywhere else, is important.
1105 We can't have existing cleanups when a Scheme exception is thrown. */
1107 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1108 &encoding_arg_pos
, &encoding
,
1109 &errors_arg_pos
, &errors
,
1110 &length_arg_pos
, &length
);
1112 cleanups
= make_cleanup (xfree
, encoding
);
1114 if (errors_arg_pos
> 0
1115 && errors
!= SCM_BOOL_F
1116 && !scm_is_eq (errors
, error_symbol
)
1117 && !scm_is_eq (errors
, substitute_symbol
))
1120 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1121 _("invalid error kind"));
1123 do_cleanups (cleanups
);
1124 gdbscm_throw (excp
);
1126 if (errors
== SCM_BOOL_F
)
1128 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1129 will throw a Scheme error when passed #f. */
1130 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1131 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1133 errors
= error_symbol
;
1135 /* We don't assume anything about the result of scm_port_conversion_strategy.
1136 From this point on, if errors is not 'errors, use 'substitute. */
1140 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1142 CATCH (except
, RETURN_MASK_ALL
)
1144 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1148 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1149 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1150 discard_cleanups (cleanups
);
1152 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1154 gdbscm_dynwind_xfree (encoding
);
1155 gdbscm_dynwind_xfree (buffer
);
1157 result
= scm_from_stringn ((const char *) buffer
,
1158 length
* TYPE_LENGTH (char_type
),
1159 (encoding
!= NULL
&& *encoding
!= '\0'
1162 scm_is_eq (errors
, error_symbol
)
1163 ? SCM_FAILED_CONVERSION_ERROR
1164 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1171 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1172 -> <gdb:lazy-string>
1173 Return a Scheme object representing a lazy_string_object type.
1174 A lazy string is a pointer to a string with an optional encoding and length.
1175 If ENCODING is not given, the target's charset is used.
1176 If LENGTH is provided then the length parameter is set to LENGTH.
1177 Otherwise if the value is an array of known length then the array's length
1178 is used. Otherwise the length will be set to -1 (meaning first null of
1180 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1183 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1186 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1187 struct value
*value
= v_smob
->value
;
1188 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1189 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1190 char *encoding
= NULL
;
1192 SCM result
= SCM_BOOL_F
; /* -Wall */
1193 struct cleanup
*cleanups
;
1194 struct gdb_exception except
= exception_none
;
1196 /* The sequencing here, as everywhere else, is important.
1197 We can't have existing cleanups when a Scheme exception is thrown. */
1199 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1200 &encoding_arg_pos
, &encoding
,
1201 &length_arg_pos
, &length
);
1205 gdbscm_out_of_range_error (FUNC_NAME
, length_arg_pos
,
1206 scm_from_int (length
),
1207 _("invalid length"));
1210 cleanups
= make_cleanup (xfree
, encoding
);
1214 struct cleanup
*inner_cleanup
1215 = make_cleanup_value_free_to_mark (value_mark ());
1216 struct type
*type
, *realtype
;
1219 type
= value_type (value
);
1220 realtype
= check_typedef (type
);
1222 switch (TYPE_CODE (realtype
))
1224 case TYPE_CODE_ARRAY
:
1226 LONGEST array_length
= -1;
1227 LONGEST low_bound
, high_bound
;
1229 /* PR 20786: There's no way to specify an array of length zero.
1230 Record a length of [0,-1] which is how Ada does it. Anything
1231 we do is broken, but this one possible solution. */
1232 if (get_array_bounds (realtype
, &low_bound
, &high_bound
))
1233 array_length
= high_bound
- low_bound
+ 1;
1235 length
= array_length
;
1236 else if (array_length
== -1)
1238 type
= lookup_array_range_type (TYPE_TARGET_TYPE (realtype
),
1241 else if (length
!= array_length
)
1243 /* We need to create a new array type with the
1244 specified length. */
1245 if (length
> array_length
)
1246 error (_("length is larger than array size"));
1247 type
= lookup_array_range_type (TYPE_TARGET_TYPE (type
),
1249 low_bound
+ length
- 1);
1251 addr
= value_address (value
);
1255 /* If a length is specified we defer creating an array of the
1256 specified width until we need to. */
1257 addr
= value_as_address (value
);
1260 /* Should flag an error here. PR 20769. */
1261 addr
= value_address (value
);
1265 result
= lsscm_make_lazy_string (addr
, length
, encoding
, type
);
1267 do_cleanups (inner_cleanup
);
1269 CATCH (ex
, RETURN_MASK_ALL
)
1275 do_cleanups (cleanups
);
1276 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1278 if (gdbscm_is_exception (result
))
1279 gdbscm_throw (result
);
1284 /* (value-lazy? <gdb:value>) -> boolean */
1287 gdbscm_value_lazy_p (SCM self
)
1290 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1291 struct value
*value
= v_smob
->value
;
1293 return scm_from_bool (value_lazy (value
));
1296 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1299 gdbscm_value_fetch_lazy_x (SCM self
)
1302 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1303 struct value
*value
= v_smob
->value
;
1307 if (value_lazy (value
))
1308 value_fetch_lazy (value
);
1310 CATCH (except
, RETURN_MASK_ALL
)
1312 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1316 return SCM_UNSPECIFIED
;
1319 /* (value-print <gdb:value>) -> string */
1322 gdbscm_value_print (SCM self
)
1325 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1326 struct value
*value
= v_smob
->value
;
1327 struct value_print_options opts
;
1329 get_user_print_options (&opts
);
1336 common_val_print (value
, &stb
, 0, &opts
, current_language
);
1338 CATCH (except
, RETURN_MASK_ALL
)
1340 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1344 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1345 throw an error if the encoding fails.
1346 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1347 override the default port conversion handler because contrary to
1348 documentation it doesn't necessarily free the input string. */
1349 return scm_from_stringn (stb
.c_str (), stb
.size (), host_charset (),
1350 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1353 /* (parse-and-eval string) -> <gdb:value>
1354 Parse a string and evaluate the string as an expression. */
1357 gdbscm_parse_and_eval (SCM expr_scm
)
1360 struct value
*res_val
= NULL
;
1362 struct cleanup
*cleanups
;
1364 /* The sequencing here, as everywhere else, is important.
1365 We can't have existing cleanups when a Scheme exception is thrown. */
1367 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1368 expr_scm
, &expr_str
);
1370 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
1371 make_cleanup (xfree
, expr_str
);
1375 res_val
= parse_and_eval (expr_str
);
1377 CATCH (except
, RETURN_MASK_ALL
)
1379 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1383 gdb_assert (res_val
!= NULL
);
1384 result
= vlscm_scm_from_value (res_val
);
1386 do_cleanups (cleanups
);
1388 if (gdbscm_is_exception (result
))
1389 gdbscm_throw (result
);
1394 /* (history-ref integer) -> <gdb:value>
1395 Return the specified value from GDB's value history. */
1398 gdbscm_history_ref (SCM index
)
1401 struct value
*res_val
= NULL
; /* Initialize to appease gcc warning. */
1403 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1407 res_val
= access_value_history (i
);
1409 CATCH (except
, RETURN_MASK_ALL
)
1411 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1415 return vlscm_scm_from_value (res_val
);
1418 /* (history-append! <gdb:value>) -> index
1419 Append VALUE to GDB's value history. Return its index in the history. */
1422 gdbscm_history_append_x (SCM value
)
1428 v_smob
= vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1433 res_index
= record_latest_value (v
);
1435 CATCH (except
, RETURN_MASK_ALL
)
1437 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1441 return scm_from_int (res_index
);
1444 /* Initialize the Scheme value code. */
1446 static const scheme_function value_functions
[] =
1448 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1450 Return #t if the object is a <gdb:value> object." },
1452 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1454 Create a <gdb:value> representing object.\n\
1455 Typically this is used to convert numbers and strings to\n\
1456 <gdb:value> objects.\n\
1458 Arguments: object [#:type <gdb:type>]" },
1460 { "value-optimized-out?", 1, 0, 0,
1461 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1463 Return #t if the value has been optimizd out." },
1465 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1467 Return the address of the value." },
1469 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1471 Return the type of the value." },
1473 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1475 Return the dynamic type of the value." },
1477 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1479 Cast the value to the supplied type.\n\
1481 Arguments: <gdb:value> <gdb:type>" },
1483 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1485 Cast the value to the supplied type, as if by the C++\n\
1486 dynamic_cast operator.\n\
1488 Arguments: <gdb:value> <gdb:type>" },
1490 { "value-reinterpret-cast", 2, 0, 0,
1491 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1493 Cast the value to the supplied type, as if by the C++\n\
1494 reinterpret_cast operator.\n\
1496 Arguments: <gdb:value> <gdb:type>" },
1498 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1500 Return the result of applying the C unary * operator to the value." },
1502 { "value-referenced-value", 1, 0, 0,
1503 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1505 Given a value of a reference type, return the value referenced.\n\
1506 The difference between this function and value-dereference is that\n\
1507 the latter applies * unary operator to a value, which need not always\n\
1508 result in the value referenced.\n\
1509 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1510 value-dereference will result in a value of type 'int' while\n\
1511 value-referenced-value will result in a value of type 'int *'." },
1513 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1515 Return the specified field of the value.\n\
1517 Arguments: <gdb:value> string" },
1519 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1521 Return the value of the array at the specified index.\n\
1523 Arguments: <gdb:value> integer" },
1525 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1527 Perform an inferior function call taking the value as a pointer to the\n\
1528 function to call.\n\
1529 Each element of the argument list must be a <gdb:value> object or an object\n\
1530 that can be converted to one.\n\
1531 The result is the value returned by the function.\n\
1533 Arguments: <gdb:value> arg-list" },
1535 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1537 Return the Scheme boolean representing the GDB value.\n\
1538 The value must be \"integer like\". Pointers are ok." },
1540 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1542 Return the Scheme integer representing the GDB value.\n\
1543 The value must be \"integer like\". Pointers are ok." },
1545 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1547 Return the Scheme real number representing the GDB value.\n\
1548 The value must be a number." },
1550 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1552 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1553 No transformation, endian or otherwise, is performed." },
1555 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1557 Return the Unicode string of the value's contents.\n\
1558 If ENCODING is not given, the string is assumed to be encoded in\n\
1559 the target's charset.\n\
1560 An error setting \"error\" causes an exception to be thrown if there's\n\
1561 a decoding error. An error setting of \"substitute\" causes invalid\n\
1562 characters to be replaced with \"?\". The default is \"error\".\n\
1563 If LENGTH is provided, only fetch string to the length provided.\n\
1565 Arguments: <gdb:value>\n\
1566 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1567 [#:length length]" },
1569 { "value->lazy-string", 1, 0, 1,
1570 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1572 Return a Scheme object representing a lazily fetched Unicode string\n\
1573 of the value's contents.\n\
1574 If ENCODING is not given, the string is assumed to be encoded in\n\
1575 the target's charset.\n\
1576 If LENGTH is provided, only fetch string to the length provided.\n\
1578 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1580 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1582 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1583 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1586 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1588 Create a <gdb:value> that will be lazily fetched from the target.\n\
1590 Arguments: <gdb:type> address" },
1592 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1594 Fetch the value from the inferior, if it was lazy.\n\
1595 The result is \"unspecified\"." },
1597 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1599 Return the string representation (print form) of the value." },
1601 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1603 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1605 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1607 Return the specified value from GDB's value history." },
1609 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1611 Append the specified value onto GDB's value history." },
1617 gdbscm_initialize_values (void)
1619 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1620 sizeof (value_smob
));
1621 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1622 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1623 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1625 gdbscm_define_functions (value_functions
, 1);
1627 type_keyword
= scm_from_latin1_keyword ("type");
1628 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1629 errors_keyword
= scm_from_latin1_keyword ("errors");
1630 length_keyword
= scm_from_latin1_keyword ("length");
1632 error_symbol
= scm_from_latin1_symbol ("error");
1633 escape_symbol
= scm_from_latin1_symbol ("escape");
1634 substitute_symbol
= scm_from_latin1_symbol ("substitute");