1 /* Scheme interface to values.
3 Copyright (C) 2008-2014 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 "gdb_assert.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 "mark" function for <gdb:value>. */
129 vlscm_mark_value_smob (SCM self
)
131 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
133 scm_gc_mark (v_smob
->address
);
134 scm_gc_mark (v_smob
->type
);
135 scm_gc_mark (v_smob
->dynamic_type
);
137 return gdbscm_mark_gsmob (&v_smob
->base
);
140 /* The smob "free" function for <gdb:value>. */
143 vlscm_free_value_smob (SCM self
)
145 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
147 vlscm_forget_value_smob (v_smob
);
148 value_free (v_smob
->value
);
153 /* The smob "print" function for <gdb:value>. */
156 vlscm_print_value_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
158 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
160 struct value_print_options opts
;
161 volatile struct gdb_exception except
;
163 if (pstate
->writingp
)
164 gdbscm_printf (port
, "#<%s ", value_smob_name
);
166 get_user_print_options (&opts
);
169 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
170 invoked by write/~S. What to do here may need to evolve.
171 IWBN if we could pass an argument to format that would we could use
172 instead of writingp. */
173 opts
.raw
= !!pstate
->writingp
;
175 TRY_CATCH (except
, RETURN_MASK_ALL
)
177 struct ui_file
*stb
= mem_fileopen ();
178 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
180 common_val_print (v_smob
->value
, stb
, 0, &opts
, current_language
);
181 s
= ui_file_xstrdup (stb
, NULL
);
183 do_cleanups (old_chain
);
185 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
193 if (pstate
->writingp
)
194 scm_puts (">", port
);
196 scm_remember_upto_here_1 (self
);
198 /* Non-zero means success. */
202 /* The smob "equalp" function for <gdb:value>. */
205 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
207 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
208 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
210 volatile struct gdb_exception except
;
212 TRY_CATCH (except
, RETURN_MASK_ALL
)
214 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
216 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
218 return scm_from_bool (result
);
221 /* Low level routine to create a <gdb:value> object. */
224 vlscm_make_value_smob (void)
226 value_smob
*v_smob
= (value_smob
*)
227 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
230 /* These must be filled in by the caller. */
231 v_smob
->value
= NULL
;
235 /* These are lazily computed. */
236 v_smob
->address
= SCM_UNDEFINED
;
237 v_smob
->type
= SCM_UNDEFINED
;
238 v_smob
->dynamic_type
= SCM_UNDEFINED
;
240 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
241 gdbscm_init_gsmob (&v_smob
->base
);
246 /* Return non-zero if SCM is a <gdb:value> object. */
249 vlscm_is_value (SCM scm
)
251 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
254 /* (value? object) -> boolean */
257 gdbscm_value_p (SCM scm
)
259 return scm_from_bool (vlscm_is_value (scm
));
262 /* Create a new <gdb:value> object that encapsulates VALUE.
263 The value is released from the all_values chain so its lifetime is not
264 bound to the execution of a command. */
267 vlscm_scm_from_value (struct value
*value
)
269 /* N.B. It's important to not cause any side-effects until we know the
270 conversion worked. */
271 SCM v_scm
= vlscm_make_value_smob ();
272 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
274 v_smob
->value
= value
;
275 release_value_or_incref (value
);
276 vlscm_remember_scheme_value (v_smob
);
281 /* Returns the <gdb:value> object in SELF.
282 Throws an exception if SELF is not a <gdb:value> object. */
285 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
287 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
293 /* Returns a pointer to the value smob of SELF.
294 Throws an exception if SELF is not a <gdb:value> object. */
297 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
299 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
300 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
305 /* Return the value field of V_SCM, an object of type <gdb:value>.
306 This exists so that we don't have to export the struct's contents. */
309 vlscm_scm_to_value (SCM v_scm
)
313 gdb_assert (vlscm_is_value (v_scm
));
314 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
315 return v_smob
->value
;
320 /* (make-value x [#:type type]) -> <gdb:value> */
323 gdbscm_make_value (SCM x
, SCM rest
)
325 struct gdbarch
*gdbarch
= get_current_arch ();
326 const struct language_defn
*language
= current_language
;
327 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
328 int type_arg_pos
= -1;
329 SCM type_scm
= SCM_UNDEFINED
;
330 SCM except_scm
, result
;
332 struct type
*type
= NULL
;
334 struct cleanup
*cleanups
;
336 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
337 &type_arg_pos
, &type_scm
);
339 if (type_arg_pos
> 0)
341 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, type_arg_pos
,
343 type
= tyscm_type_smob_type (t_smob
);
346 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
348 value
= vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
349 type_arg_pos
, type_scm
, type
,
354 do_cleanups (cleanups
);
355 gdbscm_throw (except_scm
);
358 result
= vlscm_scm_from_value (value
);
360 do_cleanups (cleanups
);
362 if (gdbscm_is_exception (result
))
363 gdbscm_throw (result
);
367 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
370 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
375 struct value
*value
= NULL
;
377 struct cleanup
*cleanups
;
378 volatile struct gdb_exception except
;
380 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG1
, FUNC_NAME
);
381 type
= tyscm_type_smob_type (t_smob
);
383 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
384 address_scm
, &address
);
386 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
388 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
389 and future-proofing we do. */
390 TRY_CATCH (except
, RETURN_MASK_ALL
)
392 value
= value_from_contents_and_address (type
, NULL
, address
);
394 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
396 result
= vlscm_scm_from_value (value
);
398 do_cleanups (cleanups
);
400 if (gdbscm_is_exception (result
))
401 gdbscm_throw (result
);
405 /* (value-optimized-out? <gdb:value>) -> boolean */
408 gdbscm_value_optimized_out_p (SCM self
)
411 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
412 struct value
*value
= v_smob
->value
;
414 volatile struct gdb_exception except
;
416 TRY_CATCH (except
, RETURN_MASK_ALL
)
418 opt
= value_optimized_out (value
);
420 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
422 return scm_from_bool (opt
);
425 /* (value-address <gdb:value>) -> integer
426 Returns #f if the value doesn't have one. */
429 gdbscm_value_address (SCM self
)
432 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
433 struct value
*value
= v_smob
->value
;
435 if (SCM_UNBNDP (v_smob
->address
))
437 struct value
*res_val
= NULL
;
438 struct cleanup
*cleanup
439 = make_cleanup_value_free_to_mark (value_mark ());
441 volatile struct gdb_exception except
;
443 TRY_CATCH (except
, RETURN_MASK_ALL
)
445 res_val
= value_addr (value
);
447 if (except
.reason
< 0)
448 address
= SCM_BOOL_F
;
450 address
= vlscm_scm_from_value (res_val
);
452 do_cleanups (cleanup
);
454 if (gdbscm_is_exception (address
))
455 gdbscm_throw (address
);
457 v_smob
->address
= address
;
460 return v_smob
->address
;
463 /* (value-dereference <gdb:value>) -> <gdb:value>
464 Given a value of a pointer type, apply the C unary * operator to it. */
467 gdbscm_value_dereference (SCM self
)
470 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
471 struct value
*value
= v_smob
->value
;
473 struct value
*res_val
= NULL
;
474 struct cleanup
*cleanups
;
475 volatile struct gdb_exception except
;
477 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
479 TRY_CATCH (except
, RETURN_MASK_ALL
)
481 res_val
= value_ind (value
);
483 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
485 result
= vlscm_scm_from_value (res_val
);
487 do_cleanups (cleanups
);
489 if (gdbscm_is_exception (result
))
490 gdbscm_throw (result
);
495 /* (value-referenced-value <gdb:value>) -> <gdb:value>
496 Given a value of a reference type, return the value referenced.
497 The difference between this function and gdbscm_value_dereference is that
498 the latter applies * unary operator to a value, which need not always
499 result in the value referenced.
500 For example, for a value which is a reference to an 'int' pointer ('int *'),
501 gdbscm_value_dereference will result in a value of type 'int' while
502 gdbscm_value_referenced_value will result in a value of type 'int *'. */
505 gdbscm_value_referenced_value (SCM self
)
508 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
509 struct value
*value
= v_smob
->value
;
511 struct value
*res_val
= NULL
;
512 struct cleanup
*cleanups
;
513 volatile struct gdb_exception except
;
515 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
517 TRY_CATCH (except
, RETURN_MASK_ALL
)
519 switch (TYPE_CODE (check_typedef (value_type (value
))))
522 res_val
= value_ind (value
);
525 res_val
= coerce_ref (value
);
528 error (_("Trying to get the referenced value from a value which is"
529 " neither a pointer nor a reference"));
532 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
534 result
= vlscm_scm_from_value (res_val
);
536 do_cleanups (cleanups
);
538 if (gdbscm_is_exception (result
))
539 gdbscm_throw (result
);
544 /* (value-type <gdb:value>) -> <gdb:type> */
547 gdbscm_value_type (SCM self
)
550 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
551 struct value
*value
= v_smob
->value
;
553 if (SCM_UNBNDP (v_smob
->type
))
554 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
559 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
562 gdbscm_value_dynamic_type (SCM self
)
565 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
566 struct value
*value
= v_smob
->value
;
567 struct type
*type
= NULL
;
568 volatile struct gdb_exception except
;
570 if (! SCM_UNBNDP (v_smob
->type
))
571 return v_smob
->dynamic_type
;
573 TRY_CATCH (except
, RETURN_MASK_ALL
)
575 struct cleanup
*cleanup
576 = make_cleanup_value_free_to_mark (value_mark ());
578 type
= value_type (value
);
579 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_CLASS
))
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_CLASS
)
603 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
606 /* Re-use object's static type. */
610 do_cleanups (cleanup
);
612 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
615 v_smob
->dynamic_type
= gdbscm_value_type (self
);
617 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
619 return v_smob
->dynamic_type
;
622 /* A helper function that implements the various cast operators. */
625 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
626 const char *func_name
)
629 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
630 struct value
*value
= v_smob
->value
;
632 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
633 struct type
*type
= tyscm_type_smob_type (t_smob
);
635 struct value
*res_val
= NULL
;
636 struct cleanup
*cleanups
;
637 volatile struct gdb_exception except
;
639 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
641 TRY_CATCH (except
, RETURN_MASK_ALL
)
643 if (op
== UNOP_DYNAMIC_CAST
)
644 res_val
= value_dynamic_cast (type
, value
);
645 else if (op
== UNOP_REINTERPRET_CAST
)
646 res_val
= value_reinterpret_cast (type
, value
);
649 gdb_assert (op
== UNOP_CAST
);
650 res_val
= value_cast (type
, value
);
653 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
655 gdb_assert (res_val
!= NULL
);
656 result
= vlscm_scm_from_value (res_val
);
658 do_cleanups (cleanups
);
660 if (gdbscm_is_exception (result
))
661 gdbscm_throw (result
);
666 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
669 gdbscm_value_cast (SCM self
, SCM new_type
)
671 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
674 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
677 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
679 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
682 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
685 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
687 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
690 /* (value-field <gdb:value> string) -> <gdb:value>
691 Given string name of an element inside structure, return its <gdb:value>
695 gdbscm_value_field (SCM self
, SCM field_scm
)
698 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
699 struct value
*value
= v_smob
->value
;
701 struct value
*res_val
= NULL
;
703 struct cleanup
*cleanups
;
704 volatile struct gdb_exception except
;
706 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
709 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
711 field
= gdbscm_scm_to_c_string (field_scm
);
712 make_cleanup (xfree
, field
);
714 TRY_CATCH (except
, RETURN_MASK_ALL
)
716 struct value
*tmp
= value
;
718 res_val
= value_struct_elt (&tmp
, NULL
, field
, NULL
, NULL
);
720 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
722 gdb_assert (res_val
!= NULL
);
723 result
= vlscm_scm_from_value (res_val
);
725 do_cleanups (cleanups
);
727 if (gdbscm_is_exception (result
))
728 gdbscm_throw (result
);
733 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
734 Return the specified value in an array. */
737 gdbscm_value_subscript (SCM self
, SCM index_scm
)
740 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
741 struct value
*value
= v_smob
->value
;
742 struct value
*index
= NULL
;
743 struct value
*res_val
= NULL
;
744 struct type
*type
= value_type (value
);
745 struct gdbarch
*gdbarch
;
746 SCM result
, except_scm
;
747 struct cleanup
*cleanups
;
748 volatile struct gdb_exception except
;
750 /* The sequencing here, as everywhere else, is important.
751 We can't have existing cleanups when a Scheme exception is thrown. */
753 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
754 gdbarch
= get_type_arch (type
);
756 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
758 index
= vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
760 gdbarch
, current_language
);
763 do_cleanups (cleanups
);
764 gdbscm_throw (except_scm
);
767 TRY_CATCH (except
, RETURN_MASK_ALL
)
769 struct value
*tmp
= value
;
771 /* Assume we are attempting an array access, and let the value code
772 throw an exception if the index has an invalid type.
773 Check the value's type is something that can be accessed via
775 tmp
= coerce_ref (tmp
);
776 type
= check_typedef (value_type (tmp
));
777 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
778 && TYPE_CODE (type
) != TYPE_CODE_PTR
)
779 error (_("Cannot subscript requested type"));
781 res_val
= value_subscript (tmp
, value_as_long (index
));
783 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
785 gdb_assert (res_val
!= NULL
);
786 result
= vlscm_scm_from_value (res_val
);
788 do_cleanups (cleanups
);
790 if (gdbscm_is_exception (result
))
791 gdbscm_throw (result
);
796 /* (value-call <gdb:value> arg-list) -> <gdb:value>
797 Perform an inferior function call on the value. */
800 gdbscm_value_call (SCM self
, SCM args
)
803 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
804 struct value
*function
= v_smob
->value
;
805 struct value
*mark
= value_mark ();
806 struct type
*ftype
= NULL
;
808 struct value
**vargs
= NULL
;
809 SCM result
= SCM_BOOL_F
;
810 volatile struct gdb_exception except
;
812 TRY_CATCH (except
, RETURN_MASK_ALL
)
814 ftype
= check_typedef (value_type (function
));
816 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
818 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
820 _("function (value of TYPE_CODE_FUNC)"));
822 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
823 SCM_ARG2
, FUNC_NAME
, _("list"));
825 args_count
= scm_ilength (args
);
828 struct gdbarch
*gdbarch
= get_current_arch ();
829 const struct language_defn
*language
= current_language
;
833 vargs
= alloca (sizeof (struct value
*) * args_count
);
834 for (i
= 0; i
< args_count
; i
++)
836 SCM arg
= scm_car (args
);
838 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
839 GDBSCM_ARG_NONE
, arg
,
842 if (vargs
[i
] == NULL
)
843 gdbscm_throw (except_scm
);
845 args
= scm_cdr (args
);
847 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
850 TRY_CATCH (except
, RETURN_MASK_ALL
)
852 struct cleanup
*cleanup
= make_cleanup_value_free_to_mark (mark
);
853 struct value
*return_value
;
855 return_value
= call_function_by_hand (function
, args_count
, vargs
);
856 result
= vlscm_scm_from_value (return_value
);
857 do_cleanups (cleanup
);
859 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
861 if (gdbscm_is_exception (result
))
862 gdbscm_throw (result
);
867 /* (value->bytevector <gdb:value>) -> bytevector */
870 gdbscm_value_to_bytevector (SCM self
)
873 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
874 struct value
*value
= v_smob
->value
;
877 const gdb_byte
*contents
= NULL
;
879 volatile struct gdb_exception except
;
881 type
= value_type (value
);
883 TRY_CATCH (except
, RETURN_MASK_ALL
)
885 CHECK_TYPEDEF (type
);
886 length
= TYPE_LENGTH (type
);
887 contents
= value_contents (value
);
889 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
891 bv
= scm_c_make_bytevector (length
);
892 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
897 /* Helper function to determine if a type is "int-like". */
900 is_intlike (struct type
*type
, int ptr_ok
)
902 return (TYPE_CODE (type
) == TYPE_CODE_INT
903 || TYPE_CODE (type
) == TYPE_CODE_ENUM
904 || TYPE_CODE (type
) == TYPE_CODE_BOOL
905 || TYPE_CODE (type
) == TYPE_CODE_CHAR
906 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
909 /* (value->bool <gdb:value>) -> boolean
910 Throws an error if the value is not integer-like. */
913 gdbscm_value_to_bool (SCM self
)
916 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
917 struct value
*value
= v_smob
->value
;
920 volatile struct gdb_exception except
;
922 type
= value_type (value
);
924 TRY_CATCH (except
, RETURN_MASK_ALL
)
926 CHECK_TYPEDEF (type
);
928 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
930 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
931 _("integer-like gdb value"));
933 TRY_CATCH (except
, RETURN_MASK_ALL
)
935 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
936 l
= value_as_address (value
);
938 l
= value_as_long (value
);
940 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
942 return scm_from_bool (l
!= 0);
945 /* (value->integer <gdb:value>) -> integer
946 Throws an error if the value is not integer-like. */
949 gdbscm_value_to_integer (SCM self
)
952 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
953 struct value
*value
= v_smob
->value
;
956 volatile struct gdb_exception except
;
958 type
= value_type (value
);
960 TRY_CATCH (except
, RETURN_MASK_ALL
)
962 CHECK_TYPEDEF (type
);
964 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
966 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
967 _("integer-like gdb value"));
969 TRY_CATCH (except
, RETURN_MASK_ALL
)
971 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
972 l
= value_as_address (value
);
974 l
= value_as_long (value
);
976 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
978 if (TYPE_UNSIGNED (type
))
979 return gdbscm_scm_from_ulongest (l
);
981 return gdbscm_scm_from_longest (l
);
984 /* (value->real <gdb:value>) -> real
985 Throws an error if the value is not a number. */
988 gdbscm_value_to_real (SCM self
)
991 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
992 struct value
*value
= v_smob
->value
;
995 volatile struct gdb_exception except
;
997 type
= value_type (value
);
999 TRY_CATCH (except
, RETURN_MASK_ALL
)
1001 CHECK_TYPEDEF (type
);
1003 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1005 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
1006 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
1008 TRY_CATCH (except
, RETURN_MASK_ALL
)
1010 d
= value_as_double (value
);
1012 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1014 /* TODO: Is there a better way to check if the value fits? */
1015 if (d
!= (double) d
)
1016 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1017 _("number can't be converted to a double"));
1019 return scm_from_double (d
);
1022 /* (value->string <gdb:value>
1023 [#:encoding encoding]
1024 [#:errors #f | 'error | 'substitute]
1027 Return Unicode string with value's contents, which must be a string.
1029 If ENCODING is not given, the string is assumed to be encoded in
1030 the target's charset.
1032 ERRORS is one of #f, 'error or 'substitute.
1033 An error setting of #f means use the default, which is
1034 Guile's %default-port-conversion-strategy. If the default is not one
1035 of 'error or 'substitute, 'substitute is used.
1036 An error setting of "error" causes an exception to be thrown if there's
1037 a decoding error. An error setting of "substitute" causes invalid
1038 characters to be replaced with "?".
1040 If LENGTH is provided, only fetch string to the length provided.
1041 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1044 gdbscm_value_to_string (SCM self
, SCM rest
)
1047 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1048 struct value
*value
= v_smob
->value
;
1049 const SCM keywords
[] = {
1050 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
1052 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
1053 char *encoding
= NULL
;
1054 SCM errors
= SCM_BOOL_F
;
1056 gdb_byte
*buffer
= NULL
;
1057 const char *la_encoding
= NULL
;
1058 struct type
*char_type
= NULL
;
1060 struct cleanup
*cleanups
;
1061 volatile struct gdb_exception except
;
1063 /* The sequencing here, as everywhere else, is important.
1064 We can't have existing cleanups when a Scheme exception is thrown. */
1066 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1067 &encoding_arg_pos
, &encoding
,
1068 &errors_arg_pos
, &errors
,
1069 &length_arg_pos
, &length
);
1071 cleanups
= make_cleanup (xfree
, encoding
);
1073 if (errors_arg_pos
> 0
1074 && errors
!= SCM_BOOL_F
1075 && !scm_is_eq (errors
, error_symbol
)
1076 && !scm_is_eq (errors
, substitute_symbol
))
1079 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1080 _("invalid error kind"));
1082 do_cleanups (cleanups
);
1083 gdbscm_throw (excp
);
1085 if (errors
== SCM_BOOL_F
)
1086 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1087 /* We don't assume anything about the result of scm_port_conversion_strategy.
1088 From this point on, if errors is not 'errors, use 'substitute. */
1090 TRY_CATCH (except
, RETURN_MASK_ALL
)
1092 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1094 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1096 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1097 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1098 discard_cleanups (cleanups
);
1100 scm_dynwind_begin (0);
1102 gdbscm_dynwind_xfree (encoding
);
1103 gdbscm_dynwind_xfree (buffer
);
1105 result
= scm_from_stringn ((const char *) buffer
,
1106 length
* TYPE_LENGTH (char_type
),
1107 (encoding
!= NULL
&& *encoding
!= '\0'
1110 scm_is_eq (errors
, error_symbol
)
1111 ? SCM_FAILED_CONVERSION_ERROR
1112 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1119 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1120 -> <gdb:lazy-string>
1121 Return a Scheme object representing a lazy_string_object type.
1122 A lazy string is a pointer to a string with an optional encoding and length.
1123 If ENCODING is not given, the target's charset is used.
1124 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1125 length will be set to -1 (first null of appropriate with).
1126 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1129 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1132 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1133 struct value
*value
= v_smob
->value
;
1134 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1135 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1136 char *encoding
= NULL
;
1138 SCM result
= SCM_BOOL_F
; /* -Wall */
1139 struct cleanup
*cleanups
;
1140 volatile struct gdb_exception except
;
1142 /* The sequencing here, as everywhere else, is important.
1143 We can't have existing cleanups when a Scheme exception is thrown. */
1145 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1146 &encoding_arg_pos
, &encoding
,
1147 &length_arg_pos
, &length
);
1149 cleanups
= make_cleanup (xfree
, encoding
);
1151 TRY_CATCH (except
, RETURN_MASK_ALL
)
1153 struct cleanup
*inner_cleanup
1154 = make_cleanup_value_free_to_mark (value_mark ());
1156 if (TYPE_CODE (value_type (value
)) == TYPE_CODE_PTR
)
1157 value
= value_ind (value
);
1159 result
= lsscm_make_lazy_string (value_address (value
), length
,
1160 encoding
, value_type (value
));
1162 do_cleanups (inner_cleanup
);
1164 do_cleanups (cleanups
);
1165 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1167 if (gdbscm_is_exception (result
))
1168 gdbscm_throw (result
);
1173 /* (value-lazy? <gdb:value>) -> boolean */
1176 gdbscm_value_lazy_p (SCM self
)
1179 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1180 struct value
*value
= v_smob
->value
;
1182 return scm_from_bool (value_lazy (value
));
1185 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1188 gdbscm_value_fetch_lazy_x (SCM self
)
1191 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1192 struct value
*value
= v_smob
->value
;
1193 volatile struct gdb_exception except
;
1195 TRY_CATCH (except
, RETURN_MASK_ALL
)
1197 if (value_lazy (value
))
1198 value_fetch_lazy (value
);
1200 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1202 return SCM_UNSPECIFIED
;
1205 /* (value-print <gdb:value>) -> string */
1208 gdbscm_value_print (SCM self
)
1211 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1212 struct value
*value
= v_smob
->value
;
1213 struct value_print_options opts
;
1216 volatile struct gdb_exception except
;
1218 get_user_print_options (&opts
);
1221 TRY_CATCH (except
, RETURN_MASK_ALL
)
1223 struct ui_file
*stb
= mem_fileopen ();
1224 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
1226 common_val_print (value
, stb
, 0, &opts
, current_language
);
1227 s
= ui_file_xstrdup (stb
, NULL
);
1229 do_cleanups (old_chain
);
1231 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1233 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1234 throw an error if the encoding fails.
1235 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1236 override the default port conversion handler because contrary to
1237 documentation it doesn't necessarily free the input string. */
1238 result
= scm_from_stringn (s
, strlen (s
), host_charset (),
1239 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1245 /* (parse-and-eval string) -> <gdb:value>
1246 Parse a string and evaluate the string as an expression. */
1249 gdbscm_parse_and_eval (SCM expr_scm
)
1252 struct value
*res_val
= NULL
;
1254 struct cleanup
*cleanups
;
1255 volatile struct gdb_exception except
;
1257 /* The sequencing here, as everywhere else, is important.
1258 We can't have existing cleanups when a Scheme exception is thrown. */
1260 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1261 expr_scm
, &expr_str
);
1263 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
1264 make_cleanup (xfree
, expr_str
);
1266 TRY_CATCH (except
, RETURN_MASK_ALL
)
1268 res_val
= parse_and_eval (expr_str
);
1270 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1272 gdb_assert (res_val
!= NULL
);
1273 result
= vlscm_scm_from_value (res_val
);
1275 do_cleanups (cleanups
);
1277 if (gdbscm_is_exception (result
))
1278 gdbscm_throw (result
);
1283 /* (history-ref integer) -> <gdb:value>
1284 Return the specified value from GDB's value history. */
1287 gdbscm_history_ref (SCM index
)
1290 struct value
*res_val
= NULL
; /* Initialize to appease gcc warning. */
1291 volatile struct gdb_exception except
;
1293 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1295 TRY_CATCH (except
, RETURN_MASK_ALL
)
1297 res_val
= access_value_history (i
);
1299 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1301 return vlscm_scm_from_value (res_val
);
1304 /* (history-append! <gdb:value>) -> index
1305 Append VALUE to GDB's value history. Return its index in the history. */
1308 gdbscm_history_append_x (SCM value
)
1312 volatile struct gdb_exception except
;
1314 v
= vlscm_scm_to_value (value
);
1316 TRY_CATCH (except
, RETURN_MASK_ALL
)
1318 res_index
= record_latest_value (v
);
1320 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1322 return scm_from_int (res_index
);
1325 /* Initialize the Scheme value code. */
1327 static const scheme_function value_functions
[] =
1329 { "value?", 1, 0, 0, gdbscm_value_p
,
1331 Return #t if the object is a <gdb:value> object." },
1333 { "make-value", 1, 0, 1, gdbscm_make_value
,
1335 Create a <gdb:value> representing object.\n\
1336 Typically this is used to convert numbers and strings to\n\
1337 <gdb:value> objects.\n\
1339 Arguments: object [#:type <gdb:type>]" },
1341 { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p
,
1343 Return #t if the value has been optimizd out." },
1345 { "value-address", 1, 0, 0, gdbscm_value_address
,
1347 Return the address of the value." },
1349 { "value-type", 1, 0, 0, gdbscm_value_type
,
1351 Return the type of the value." },
1353 { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type
,
1355 Return the dynamic type of the value." },
1357 { "value-cast", 2, 0, 0, gdbscm_value_cast
,
1359 Cast the value to the supplied type.\n\
1361 Arguments: <gdb:value> <gdb:type>" },
1363 { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast
,
1365 Cast the value to the supplied type, as if by the C++\n\
1366 dynamic_cast operator.\n\
1368 Arguments: <gdb:value> <gdb:type>" },
1370 { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast
,
1372 Cast the value to the supplied type, as if by the C++\n\
1373 reinterpret_cast operator.\n\
1375 Arguments: <gdb:value> <gdb:type>" },
1377 { "value-dereference", 1, 0, 0, gdbscm_value_dereference
,
1379 Return the result of applying the C unary * operator to the value." },
1381 { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value
,
1383 Given a value of a reference type, return the value referenced.\n\
1384 The difference between this function and value-dereference is that\n\
1385 the latter applies * unary operator to a value, which need not always\n\
1386 result in the value referenced.\n\
1387 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1388 value-dereference will result in a value of type 'int' while\n\
1389 value-referenced-value will result in a value of type 'int *'." },
1391 { "value-field", 2, 0, 0, gdbscm_value_field
,
1393 Return the specified field of the value.\n\
1395 Arguments: <gdb:value> string" },
1397 { "value-subscript", 2, 0, 0, gdbscm_value_subscript
,
1399 Return the value of the array at the specified index.\n\
1401 Arguments: <gdb:value> integer" },
1403 { "value-call", 2, 0, 0, gdbscm_value_call
,
1405 Perform an inferior function call taking the value as a pointer to the\n\
1406 function to call.\n\
1407 Each element of the argument list must be a <gdb:value> object or an object\n\
1408 that can be converted to one.\n\
1409 The result is the value returned by the function.\n\
1411 Arguments: <gdb:value> arg-list" },
1413 { "value->bool", 1, 0, 0, gdbscm_value_to_bool
,
1415 Return the Scheme boolean representing the GDB value.\n\
1416 The value must be \"integer like\". Pointers are ok." },
1418 { "value->integer", 1, 0, 0, gdbscm_value_to_integer
,
1420 Return the Scheme integer representing the GDB value.\n\
1421 The value must be \"integer like\". Pointers are ok." },
1423 { "value->real", 1, 0, 0, gdbscm_value_to_real
,
1425 Return the Scheme real number representing the GDB value.\n\
1426 The value must be a number." },
1428 { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector
,
1430 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1431 No transformation, endian or otherwise, is performed." },
1433 { "value->string", 1, 0, 1, gdbscm_value_to_string
,
1435 Return the Unicode string of the value's contents.\n\
1436 If ENCODING is not given, the string is assumed to be encoded in\n\
1437 the target's charset.\n\
1438 An error setting \"error\" causes an exception to be thrown if there's\n\
1439 a decoding error. An error setting of \"substitute\" causes invalid\n\
1440 characters to be replaced with \"?\". The default is \"error\".\n\
1441 If LENGTH is provided, only fetch string to the length provided.\n\
1443 Arguments: <gdb:value>\n\
1444 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1445 [#:length length]" },
1447 { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string
,
1449 Return a Scheme object representing a lazily fetched Unicode string\n\
1450 of the value's contents.\n\
1451 If ENCODING is not given, the string is assumed to be encoded in\n\
1452 the target's charset.\n\
1453 If LENGTH is provided, only fetch string to the length provided.\n\
1455 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1457 { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p
,
1459 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1460 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1463 { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value
,
1465 Create a <gdb:value> that will be lazily fetched from the target.\n\
1467 Arguments: <gdb:type> address" },
1469 { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x
,
1471 Fetch the value from the inferior, if it was lazy.\n\
1472 The result is \"unspecified\"." },
1474 { "value-print", 1, 0, 0, gdbscm_value_print
,
1476 Return the string representation (print form) of the value." },
1478 { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval
,
1480 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1482 { "history-ref", 1, 0, 0, gdbscm_history_ref
,
1484 Return the specified value from GDB's value history." },
1486 { "history-append!", 1, 0, 0, gdbscm_history_append_x
,
1488 Append the specified value onto GDB's value history." },
1494 gdbscm_initialize_values (void)
1496 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1497 sizeof (value_smob
));
1498 scm_set_smob_mark (value_smob_tag
, vlscm_mark_value_smob
);
1499 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1500 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1501 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1503 gdbscm_define_functions (value_functions
, 1);
1505 type_keyword
= scm_from_latin1_keyword ("type");
1506 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1507 errors_keyword
= scm_from_latin1_keyword ("errors");
1508 length_keyword
= scm_from_latin1_keyword ("length");
1510 error_symbol
= scm_from_latin1_symbol ("error");
1511 escape_symbol
= scm_from_latin1_symbol ("escape");
1512 substitute_symbol
= scm_from_latin1_symbol ("substitute");