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
;
160 struct ui_file
*stb
= mem_fileopen ();
161 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
163 common_val_print (v_smob
->value
, stb
, 0, &opts
, current_language
);
165 std::string s
= ui_file_as_string (stb
);
166 scm_puts (s
.c_str (), port
);
168 do_cleanups (old_chain
);
170 CATCH (except
, RETURN_MASK_ALL
)
172 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
176 if (pstate
->writingp
)
177 scm_puts (">", port
);
179 scm_remember_upto_here_1 (self
);
181 /* Non-zero means success. */
185 /* The smob "equalp" function for <gdb:value>. */
188 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
190 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
191 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
196 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
198 CATCH (except
, RETURN_MASK_ALL
)
200 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
204 return scm_from_bool (result
);
207 /* Low level routine to create a <gdb:value> object. */
210 vlscm_make_value_smob (void)
212 value_smob
*v_smob
= (value_smob
*)
213 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
216 /* These must be filled in by the caller. */
217 v_smob
->value
= NULL
;
221 /* These are lazily computed. */
222 v_smob
->address
= SCM_UNDEFINED
;
223 v_smob
->type
= SCM_UNDEFINED
;
224 v_smob
->dynamic_type
= SCM_UNDEFINED
;
226 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
227 gdbscm_init_gsmob (&v_smob
->base
);
232 /* Return non-zero if SCM is a <gdb:value> object. */
235 vlscm_is_value (SCM scm
)
237 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
240 /* (value? object) -> boolean */
243 gdbscm_value_p (SCM scm
)
245 return scm_from_bool (vlscm_is_value (scm
));
248 /* Create a new <gdb:value> object that encapsulates VALUE.
249 The value is released from the all_values chain so its lifetime is not
250 bound to the execution of a command. */
253 vlscm_scm_from_value (struct value
*value
)
255 /* N.B. It's important to not cause any side-effects until we know the
256 conversion worked. */
257 SCM v_scm
= vlscm_make_value_smob ();
258 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
260 v_smob
->value
= value
;
261 release_value_or_incref (value
);
262 vlscm_remember_scheme_value (v_smob
);
267 /* Returns the <gdb:value> object in SELF.
268 Throws an exception if SELF is not a <gdb:value> object. */
271 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
273 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
279 /* Returns a pointer to the value smob of SELF.
280 Throws an exception if SELF is not a <gdb:value> object. */
283 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
285 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
286 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
291 /* Return the value field of V_SCM, an object of type <gdb:value>.
292 This exists so that we don't have to export the struct's contents. */
295 vlscm_scm_to_value (SCM v_scm
)
299 gdb_assert (vlscm_is_value (v_scm
));
300 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
301 return v_smob
->value
;
306 /* (make-value x [#:type type]) -> <gdb:value> */
309 gdbscm_make_value (SCM x
, SCM rest
)
311 struct gdbarch
*gdbarch
= get_current_arch ();
312 const struct language_defn
*language
= current_language
;
313 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
314 int type_arg_pos
= -1;
315 SCM type_scm
= SCM_UNDEFINED
;
316 SCM except_scm
, result
;
318 struct type
*type
= NULL
;
320 struct cleanup
*cleanups
;
322 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
323 &type_arg_pos
, &type_scm
);
325 if (type_arg_pos
> 0)
327 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, type_arg_pos
,
329 type
= tyscm_type_smob_type (t_smob
);
332 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
334 value
= vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
335 type_arg_pos
, type_scm
, type
,
340 do_cleanups (cleanups
);
341 gdbscm_throw (except_scm
);
344 result
= vlscm_scm_from_value (value
);
346 do_cleanups (cleanups
);
348 if (gdbscm_is_exception (result
))
349 gdbscm_throw (result
);
353 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
356 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
361 struct value
*value
= NULL
;
363 struct cleanup
*cleanups
;
365 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG1
, FUNC_NAME
);
366 type
= tyscm_type_smob_type (t_smob
);
368 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
369 address_scm
, &address
);
371 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
373 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
374 and future-proofing we do. */
377 value
= value_from_contents_and_address (type
, NULL
, address
);
379 CATCH (except
, RETURN_MASK_ALL
)
381 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
385 result
= vlscm_scm_from_value (value
);
387 do_cleanups (cleanups
);
389 if (gdbscm_is_exception (result
))
390 gdbscm_throw (result
);
394 /* (value-optimized-out? <gdb:value>) -> boolean */
397 gdbscm_value_optimized_out_p (SCM self
)
400 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
401 struct value
*value
= v_smob
->value
;
406 opt
= value_optimized_out (value
);
408 CATCH (except
, RETURN_MASK_ALL
)
410 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
414 return scm_from_bool (opt
);
417 /* (value-address <gdb:value>) -> integer
418 Returns #f if the value doesn't have one. */
421 gdbscm_value_address (SCM self
)
424 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
425 struct value
*value
= v_smob
->value
;
427 if (SCM_UNBNDP (v_smob
->address
))
429 struct value
*res_val
= NULL
;
430 struct cleanup
*cleanup
431 = make_cleanup_value_free_to_mark (value_mark ());
436 res_val
= value_addr (value
);
438 CATCH (except
, RETURN_MASK_ALL
)
440 address
= SCM_BOOL_F
;
445 address
= vlscm_scm_from_value (res_val
);
447 do_cleanups (cleanup
);
449 if (gdbscm_is_exception (address
))
450 gdbscm_throw (address
);
452 v_smob
->address
= address
;
455 return v_smob
->address
;
458 /* (value-dereference <gdb:value>) -> <gdb:value>
459 Given a value of a pointer type, apply the C unary * operator to it. */
462 gdbscm_value_dereference (SCM self
)
465 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
466 struct value
*value
= v_smob
->value
;
468 struct value
*res_val
= NULL
;
469 struct cleanup
*cleanups
;
471 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
475 res_val
= value_ind (value
);
477 CATCH (except
, RETURN_MASK_ALL
)
479 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
483 result
= vlscm_scm_from_value (res_val
);
485 do_cleanups (cleanups
);
487 if (gdbscm_is_exception (result
))
488 gdbscm_throw (result
);
493 /* (value-referenced-value <gdb:value>) -> <gdb:value>
494 Given a value of a reference type, return the value referenced.
495 The difference between this function and gdbscm_value_dereference is that
496 the latter applies * unary operator to a value, which need not always
497 result in the value referenced.
498 For example, for a value which is a reference to an 'int' pointer ('int *'),
499 gdbscm_value_dereference will result in a value of type 'int' while
500 gdbscm_value_referenced_value will result in a value of type 'int *'. */
503 gdbscm_value_referenced_value (SCM self
)
506 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
507 struct value
*value
= v_smob
->value
;
509 struct value
*res_val
= NULL
;
510 struct cleanup
*cleanups
;
512 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
516 switch (TYPE_CODE (check_typedef (value_type (value
))))
519 res_val
= value_ind (value
);
522 res_val
= coerce_ref (value
);
525 error (_("Trying to get the referenced value from a value which is"
526 " neither a pointer nor a reference"));
529 CATCH (except
, RETURN_MASK_ALL
)
531 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
535 result
= vlscm_scm_from_value (res_val
);
537 do_cleanups (cleanups
);
539 if (gdbscm_is_exception (result
))
540 gdbscm_throw (result
);
545 /* (value-type <gdb:value>) -> <gdb:type> */
548 gdbscm_value_type (SCM self
)
551 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
552 struct value
*value
= v_smob
->value
;
554 if (SCM_UNBNDP (v_smob
->type
))
555 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
560 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
563 gdbscm_value_dynamic_type (SCM self
)
566 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
567 struct value
*value
= v_smob
->value
;
568 struct type
*type
= NULL
;
570 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
571 return v_smob
->dynamic_type
;
575 struct cleanup
*cleanup
576 = make_cleanup_value_free_to_mark (value_mark ());
578 type
= value_type (value
);
579 type
= check_typedef (type
);
581 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
582 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
583 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
585 struct value
*target
;
586 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
589 target
= value_ind (value
);
591 target
= coerce_ref (value
);
592 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
597 type
= lookup_pointer_type (type
);
599 type
= lookup_reference_type (type
);
602 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
603 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
606 /* Re-use object's static type. */
610 do_cleanups (cleanup
);
612 CATCH (except
, RETURN_MASK_ALL
)
614 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
619 v_smob
->dynamic_type
= gdbscm_value_type (self
);
621 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
623 return v_smob
->dynamic_type
;
626 /* A helper function that implements the various cast operators. */
629 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
630 const char *func_name
)
633 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
634 struct value
*value
= v_smob
->value
;
636 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
637 struct type
*type
= tyscm_type_smob_type (t_smob
);
639 struct value
*res_val
= NULL
;
640 struct cleanup
*cleanups
;
642 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
646 if (op
== UNOP_DYNAMIC_CAST
)
647 res_val
= value_dynamic_cast (type
, value
);
648 else if (op
== UNOP_REINTERPRET_CAST
)
649 res_val
= value_reinterpret_cast (type
, value
);
652 gdb_assert (op
== UNOP_CAST
);
653 res_val
= value_cast (type
, value
);
656 CATCH (except
, RETURN_MASK_ALL
)
658 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
662 gdb_assert (res_val
!= NULL
);
663 result
= vlscm_scm_from_value (res_val
);
665 do_cleanups (cleanups
);
667 if (gdbscm_is_exception (result
))
668 gdbscm_throw (result
);
673 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
676 gdbscm_value_cast (SCM self
, SCM new_type
)
678 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
681 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
684 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
686 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
689 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
692 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
694 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
697 /* (value-field <gdb:value> string) -> <gdb:value>
698 Given string name of an element inside structure, return its <gdb:value>
702 gdbscm_value_field (SCM self
, SCM field_scm
)
705 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
706 struct value
*value
= v_smob
->value
;
708 struct value
*res_val
= NULL
;
710 struct cleanup
*cleanups
;
712 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
715 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
717 field
= gdbscm_scm_to_c_string (field_scm
);
718 make_cleanup (xfree
, field
);
722 struct value
*tmp
= value
;
724 res_val
= value_struct_elt (&tmp
, NULL
, field
, NULL
,
725 "struct/class/union");
727 CATCH (except
, RETURN_MASK_ALL
)
729 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
733 gdb_assert (res_val
!= NULL
);
734 result
= vlscm_scm_from_value (res_val
);
736 do_cleanups (cleanups
);
738 if (gdbscm_is_exception (result
))
739 gdbscm_throw (result
);
744 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
745 Return the specified value in an array. */
748 gdbscm_value_subscript (SCM self
, SCM index_scm
)
751 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
752 struct value
*value
= v_smob
->value
;
753 struct value
*index
= NULL
;
754 struct value
*res_val
= NULL
;
755 struct type
*type
= value_type (value
);
756 struct gdbarch
*gdbarch
;
757 SCM result
, except_scm
;
758 struct cleanup
*cleanups
;
760 /* The sequencing here, as everywhere else, is important.
761 We can't have existing cleanups when a Scheme exception is thrown. */
763 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
764 gdbarch
= get_type_arch (type
);
766 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
768 index
= vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
770 gdbarch
, current_language
);
773 do_cleanups (cleanups
);
774 gdbscm_throw (except_scm
);
779 struct value
*tmp
= value
;
781 /* Assume we are attempting an array access, and let the value code
782 throw an exception if the index has an invalid type.
783 Check the value's type is something that can be accessed via
785 tmp
= coerce_ref (tmp
);
786 type
= check_typedef (value_type (tmp
));
787 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
788 && TYPE_CODE (type
) != TYPE_CODE_PTR
)
789 error (_("Cannot subscript requested type"));
791 res_val
= value_subscript (tmp
, value_as_long (index
));
793 CATCH (except
, RETURN_MASK_ALL
)
795 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
799 gdb_assert (res_val
!= NULL
);
800 result
= vlscm_scm_from_value (res_val
);
802 do_cleanups (cleanups
);
804 if (gdbscm_is_exception (result
))
805 gdbscm_throw (result
);
810 /* (value-call <gdb:value> arg-list) -> <gdb:value>
811 Perform an inferior function call on the value. */
814 gdbscm_value_call (SCM self
, SCM args
)
817 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
818 struct value
*function
= v_smob
->value
;
819 struct value
*mark
= value_mark ();
820 struct type
*ftype
= NULL
;
822 struct value
**vargs
= NULL
;
823 SCM result
= SCM_BOOL_F
;
827 ftype
= check_typedef (value_type (function
));
829 CATCH (except
, RETURN_MASK_ALL
)
831 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
835 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
837 _("function (value of TYPE_CODE_FUNC)"));
839 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
840 SCM_ARG2
, FUNC_NAME
, _("list"));
842 args_count
= scm_ilength (args
);
845 struct gdbarch
*gdbarch
= get_current_arch ();
846 const struct language_defn
*language
= current_language
;
850 vargs
= XALLOCAVEC (struct value
*, args_count
);
851 for (i
= 0; i
< args_count
; i
++)
853 SCM arg
= scm_car (args
);
855 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
856 GDBSCM_ARG_NONE
, arg
,
859 if (vargs
[i
] == NULL
)
860 gdbscm_throw (except_scm
);
862 args
= scm_cdr (args
);
864 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
869 struct cleanup
*cleanup
= make_cleanup_value_free_to_mark (mark
);
870 struct value
*return_value
;
872 return_value
= call_function_by_hand (function
, args_count
, vargs
);
873 result
= vlscm_scm_from_value (return_value
);
874 do_cleanups (cleanup
);
876 CATCH (except
, RETURN_MASK_ALL
)
878 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
882 if (gdbscm_is_exception (result
))
883 gdbscm_throw (result
);
888 /* (value->bytevector <gdb:value>) -> bytevector */
891 gdbscm_value_to_bytevector (SCM self
)
894 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
895 struct value
*value
= v_smob
->value
;
898 const gdb_byte
*contents
= NULL
;
901 type
= value_type (value
);
905 type
= check_typedef (type
);
906 length
= TYPE_LENGTH (type
);
907 contents
= value_contents (value
);
909 CATCH (except
, RETURN_MASK_ALL
)
911 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
915 bv
= scm_c_make_bytevector (length
);
916 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
921 /* Helper function to determine if a type is "int-like". */
924 is_intlike (struct type
*type
, int ptr_ok
)
926 return (TYPE_CODE (type
) == TYPE_CODE_INT
927 || TYPE_CODE (type
) == TYPE_CODE_ENUM
928 || TYPE_CODE (type
) == TYPE_CODE_BOOL
929 || TYPE_CODE (type
) == TYPE_CODE_CHAR
930 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
933 /* (value->bool <gdb:value>) -> boolean
934 Throws an error if the value is not integer-like. */
937 gdbscm_value_to_bool (SCM self
)
940 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
941 struct value
*value
= v_smob
->value
;
945 type
= value_type (value
);
949 type
= check_typedef (type
);
951 CATCH (except
, RETURN_MASK_ALL
)
953 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
957 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
958 _("integer-like gdb value"));
962 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
963 l
= value_as_address (value
);
965 l
= value_as_long (value
);
967 CATCH (except
, RETURN_MASK_ALL
)
969 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
973 return scm_from_bool (l
!= 0);
976 /* (value->integer <gdb:value>) -> integer
977 Throws an error if the value is not integer-like. */
980 gdbscm_value_to_integer (SCM self
)
983 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
984 struct value
*value
= v_smob
->value
;
988 type
= value_type (value
);
992 type
= check_typedef (type
);
994 CATCH (except
, RETURN_MASK_ALL
)
996 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1000 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
1001 _("integer-like gdb value"));
1005 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1006 l
= value_as_address (value
);
1008 l
= value_as_long (value
);
1010 CATCH (except
, RETURN_MASK_ALL
)
1012 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1016 if (TYPE_UNSIGNED (type
))
1017 return gdbscm_scm_from_ulongest (l
);
1019 return gdbscm_scm_from_longest (l
);
1022 /* (value->real <gdb:value>) -> real
1023 Throws an error if the value is not a number. */
1026 gdbscm_value_to_real (SCM self
)
1029 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1030 struct value
*value
= v_smob
->value
;
1034 type
= value_type (value
);
1038 type
= check_typedef (type
);
1040 CATCH (except
, RETURN_MASK_ALL
)
1042 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1046 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
1047 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
1051 d
= value_as_double (value
);
1053 CATCH (except
, RETURN_MASK_ALL
)
1055 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1059 /* TODO: Is there a better way to check if the value fits? */
1060 if (d
!= (double) d
)
1061 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1062 _("number can't be converted to a double"));
1064 return scm_from_double (d
);
1067 /* (value->string <gdb:value>
1068 [#:encoding encoding]
1069 [#:errors #f | 'error | 'substitute]
1072 Return Unicode string with value's contents, which must be a string.
1074 If ENCODING is not given, the string is assumed to be encoded in
1075 the target's charset.
1077 ERRORS is one of #f, 'error or 'substitute.
1078 An error setting of #f means use the default, which is Guile's
1079 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1080 using an earlier version of Guile. Earlier versions do not properly
1081 support obtaining the default port conversion strategy.
1082 If the default is not one of 'error or 'substitute, 'substitute is used.
1083 An error setting of "error" causes an exception to be thrown if there's
1084 a decoding error. An error setting of "substitute" causes invalid
1085 characters to be replaced with "?".
1087 If LENGTH is provided, only fetch string to the length provided.
1088 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1091 gdbscm_value_to_string (SCM self
, SCM rest
)
1094 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1095 struct value
*value
= v_smob
->value
;
1096 const SCM keywords
[] = {
1097 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
1099 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
1100 char *encoding
= NULL
;
1101 SCM errors
= SCM_BOOL_F
;
1103 gdb_byte
*buffer
= NULL
;
1104 const char *la_encoding
= NULL
;
1105 struct type
*char_type
= NULL
;
1107 struct cleanup
*cleanups
;
1109 /* The sequencing here, as everywhere else, is important.
1110 We can't have existing cleanups when a Scheme exception is thrown. */
1112 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1113 &encoding_arg_pos
, &encoding
,
1114 &errors_arg_pos
, &errors
,
1115 &length_arg_pos
, &length
);
1117 cleanups
= make_cleanup (xfree
, encoding
);
1119 if (errors_arg_pos
> 0
1120 && errors
!= SCM_BOOL_F
1121 && !scm_is_eq (errors
, error_symbol
)
1122 && !scm_is_eq (errors
, substitute_symbol
))
1125 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1126 _("invalid error kind"));
1128 do_cleanups (cleanups
);
1129 gdbscm_throw (excp
);
1131 if (errors
== SCM_BOOL_F
)
1133 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1134 will throw a Scheme error when passed #f. */
1135 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1136 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1138 errors
= error_symbol
;
1140 /* We don't assume anything about the result of scm_port_conversion_strategy.
1141 From this point on, if errors is not 'errors, use 'substitute. */
1145 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1147 CATCH (except
, RETURN_MASK_ALL
)
1149 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1153 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1154 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1155 discard_cleanups (cleanups
);
1157 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1159 gdbscm_dynwind_xfree (encoding
);
1160 gdbscm_dynwind_xfree (buffer
);
1162 result
= scm_from_stringn ((const char *) buffer
,
1163 length
* TYPE_LENGTH (char_type
),
1164 (encoding
!= NULL
&& *encoding
!= '\0'
1167 scm_is_eq (errors
, error_symbol
)
1168 ? SCM_FAILED_CONVERSION_ERROR
1169 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1176 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1177 -> <gdb:lazy-string>
1178 Return a Scheme object representing a lazy_string_object type.
1179 A lazy string is a pointer to a string with an optional encoding and length.
1180 If ENCODING is not given, the target's charset is used.
1181 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1182 length will be set to -1 (first null of appropriate with).
1183 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1186 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1189 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1190 struct value
*value
= v_smob
->value
;
1191 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1192 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1193 char *encoding
= NULL
;
1195 SCM result
= SCM_BOOL_F
; /* -Wall */
1196 struct cleanup
*cleanups
;
1197 struct gdb_exception except
= exception_none
;
1199 /* The sequencing here, as everywhere else, is important.
1200 We can't have existing cleanups when a Scheme exception is thrown. */
1202 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1203 &encoding_arg_pos
, &encoding
,
1204 &length_arg_pos
, &length
);
1206 cleanups
= make_cleanup (xfree
, encoding
);
1210 struct cleanup
*inner_cleanup
1211 = make_cleanup_value_free_to_mark (value_mark ());
1213 if (TYPE_CODE (value_type (value
)) == TYPE_CODE_PTR
)
1214 value
= value_ind (value
);
1216 result
= lsscm_make_lazy_string (value_address (value
), length
,
1217 encoding
, value_type (value
));
1219 do_cleanups (inner_cleanup
);
1221 CATCH (ex
, RETURN_MASK_ALL
)
1227 do_cleanups (cleanups
);
1228 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1230 if (gdbscm_is_exception (result
))
1231 gdbscm_throw (result
);
1236 /* (value-lazy? <gdb:value>) -> boolean */
1239 gdbscm_value_lazy_p (SCM self
)
1242 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1243 struct value
*value
= v_smob
->value
;
1245 return scm_from_bool (value_lazy (value
));
1248 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1251 gdbscm_value_fetch_lazy_x (SCM self
)
1254 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1255 struct value
*value
= v_smob
->value
;
1259 if (value_lazy (value
))
1260 value_fetch_lazy (value
);
1262 CATCH (except
, RETURN_MASK_ALL
)
1264 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1268 return SCM_UNSPECIFIED
;
1271 /* (value-print <gdb:value>) -> string */
1274 gdbscm_value_print (SCM self
)
1277 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1278 struct value
*value
= v_smob
->value
;
1279 struct value_print_options opts
;
1283 get_user_print_options (&opts
);
1288 struct ui_file
*stb
= mem_fileopen ();
1289 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
1291 common_val_print (value
, stb
, 0, &opts
, current_language
);
1292 s
= ui_file_as_string (stb
);
1294 do_cleanups (old_chain
);
1296 CATCH (except
, RETURN_MASK_ALL
)
1298 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1302 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1303 throw an error if the encoding fails.
1304 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1305 override the default port conversion handler because contrary to
1306 documentation it doesn't necessarily free the input string. */
1307 result
= scm_from_stringn (s
.c_str (), s
.size (), host_charset (),
1308 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1313 /* (parse-and-eval string) -> <gdb:value>
1314 Parse a string and evaluate the string as an expression. */
1317 gdbscm_parse_and_eval (SCM expr_scm
)
1320 struct value
*res_val
= NULL
;
1322 struct cleanup
*cleanups
;
1324 /* The sequencing here, as everywhere else, is important.
1325 We can't have existing cleanups when a Scheme exception is thrown. */
1327 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1328 expr_scm
, &expr_str
);
1330 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
1331 make_cleanup (xfree
, expr_str
);
1335 res_val
= parse_and_eval (expr_str
);
1337 CATCH (except
, RETURN_MASK_ALL
)
1339 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1343 gdb_assert (res_val
!= NULL
);
1344 result
= vlscm_scm_from_value (res_val
);
1346 do_cleanups (cleanups
);
1348 if (gdbscm_is_exception (result
))
1349 gdbscm_throw (result
);
1354 /* (history-ref integer) -> <gdb:value>
1355 Return the specified value from GDB's value history. */
1358 gdbscm_history_ref (SCM index
)
1361 struct value
*res_val
= NULL
; /* Initialize to appease gcc warning. */
1363 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1367 res_val
= access_value_history (i
);
1369 CATCH (except
, RETURN_MASK_ALL
)
1371 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1375 return vlscm_scm_from_value (res_val
);
1378 /* (history-append! <gdb:value>) -> index
1379 Append VALUE to GDB's value history. Return its index in the history. */
1382 gdbscm_history_append_x (SCM value
)
1388 v_smob
= vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1393 res_index
= record_latest_value (v
);
1395 CATCH (except
, RETURN_MASK_ALL
)
1397 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1401 return scm_from_int (res_index
);
1404 /* Initialize the Scheme value code. */
1406 static const scheme_function value_functions
[] =
1408 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1410 Return #t if the object is a <gdb:value> object." },
1412 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1414 Create a <gdb:value> representing object.\n\
1415 Typically this is used to convert numbers and strings to\n\
1416 <gdb:value> objects.\n\
1418 Arguments: object [#:type <gdb:type>]" },
1420 { "value-optimized-out?", 1, 0, 0,
1421 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1423 Return #t if the value has been optimizd out." },
1425 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1427 Return the address of the value." },
1429 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1431 Return the type of the value." },
1433 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1435 Return the dynamic type of the value." },
1437 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1439 Cast the value to the supplied type.\n\
1441 Arguments: <gdb:value> <gdb:type>" },
1443 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1445 Cast the value to the supplied type, as if by the C++\n\
1446 dynamic_cast operator.\n\
1448 Arguments: <gdb:value> <gdb:type>" },
1450 { "value-reinterpret-cast", 2, 0, 0,
1451 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1453 Cast the value to the supplied type, as if by the C++\n\
1454 reinterpret_cast operator.\n\
1456 Arguments: <gdb:value> <gdb:type>" },
1458 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1460 Return the result of applying the C unary * operator to the value." },
1462 { "value-referenced-value", 1, 0, 0,
1463 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1465 Given a value of a reference type, return the value referenced.\n\
1466 The difference between this function and value-dereference is that\n\
1467 the latter applies * unary operator to a value, which need not always\n\
1468 result in the value referenced.\n\
1469 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1470 value-dereference will result in a value of type 'int' while\n\
1471 value-referenced-value will result in a value of type 'int *'." },
1473 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1475 Return the specified field of the value.\n\
1477 Arguments: <gdb:value> string" },
1479 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1481 Return the value of the array at the specified index.\n\
1483 Arguments: <gdb:value> integer" },
1485 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1487 Perform an inferior function call taking the value as a pointer to the\n\
1488 function to call.\n\
1489 Each element of the argument list must be a <gdb:value> object or an object\n\
1490 that can be converted to one.\n\
1491 The result is the value returned by the function.\n\
1493 Arguments: <gdb:value> arg-list" },
1495 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1497 Return the Scheme boolean representing the GDB value.\n\
1498 The value must be \"integer like\". Pointers are ok." },
1500 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1502 Return the Scheme integer representing the GDB value.\n\
1503 The value must be \"integer like\". Pointers are ok." },
1505 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1507 Return the Scheme real number representing the GDB value.\n\
1508 The value must be a number." },
1510 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1512 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1513 No transformation, endian or otherwise, is performed." },
1515 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1517 Return the Unicode string of the value's contents.\n\
1518 If ENCODING is not given, the string is assumed to be encoded in\n\
1519 the target's charset.\n\
1520 An error setting \"error\" causes an exception to be thrown if there's\n\
1521 a decoding error. An error setting of \"substitute\" causes invalid\n\
1522 characters to be replaced with \"?\". The default is \"error\".\n\
1523 If LENGTH is provided, only fetch string to the length provided.\n\
1525 Arguments: <gdb:value>\n\
1526 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1527 [#:length length]" },
1529 { "value->lazy-string", 1, 0, 1,
1530 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1532 Return a Scheme object representing a lazily fetched Unicode string\n\
1533 of the value's contents.\n\
1534 If ENCODING is not given, the string is assumed to be encoded in\n\
1535 the target's charset.\n\
1536 If LENGTH is provided, only fetch string to the length provided.\n\
1538 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1540 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1542 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1543 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1546 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1548 Create a <gdb:value> that will be lazily fetched from the target.\n\
1550 Arguments: <gdb:type> address" },
1552 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1554 Fetch the value from the inferior, if it was lazy.\n\
1555 The result is \"unspecified\"." },
1557 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1559 Return the string representation (print form) of the value." },
1561 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1563 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1565 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1567 Return the specified value from GDB's value history." },
1569 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1571 Append the specified value onto GDB's value history." },
1577 gdbscm_initialize_values (void)
1579 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1580 sizeof (value_smob
));
1581 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1582 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1583 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1585 gdbscm_define_functions (value_functions
, 1);
1587 type_keyword
= scm_from_latin1_keyword ("type");
1588 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1589 errors_keyword
= scm_from_latin1_keyword ("errors");
1590 length_keyword
= scm_from_latin1_keyword ("length");
1592 error_symbol
= scm_from_latin1_symbol ("error");
1593 escape_symbol
= scm_from_latin1_symbol ("escape");
1594 substitute_symbol
= scm_from_latin1_symbol ("substitute");