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 "free" function for <gdb:value>. */
129 vlscm_free_value_smob (SCM self
)
131 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
133 vlscm_forget_value_smob (v_smob
);
134 value_free (v_smob
->value
);
139 /* The smob "print" function for <gdb:value>. */
142 vlscm_print_value_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
144 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (self
);
146 struct value_print_options opts
;
147 volatile struct gdb_exception except
;
149 if (pstate
->writingp
)
150 gdbscm_printf (port
, "#<%s ", value_smob_name
);
152 get_user_print_options (&opts
);
155 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
156 invoked by write/~S. What to do here may need to evolve.
157 IWBN if we could pass an argument to format that would we could use
158 instead of writingp. */
159 opts
.raw
= !!pstate
->writingp
;
161 TRY_CATCH (except
, RETURN_MASK_ALL
)
163 struct ui_file
*stb
= mem_fileopen ();
164 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
166 common_val_print (v_smob
->value
, stb
, 0, &opts
, current_language
);
167 s
= ui_file_xstrdup (stb
, NULL
);
169 do_cleanups (old_chain
);
171 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
179 if (pstate
->writingp
)
180 scm_puts (">", port
);
182 scm_remember_upto_here_1 (self
);
184 /* Non-zero means success. */
188 /* The smob "equalp" function for <gdb:value>. */
191 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
193 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
194 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
196 volatile struct gdb_exception except
;
198 TRY_CATCH (except
, RETURN_MASK_ALL
)
200 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
202 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
;
364 volatile struct gdb_exception except
;
366 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG1
, FUNC_NAME
);
367 type
= tyscm_type_smob_type (t_smob
);
369 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
370 address_scm
, &address
);
372 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
374 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
375 and future-proofing we do. */
376 TRY_CATCH (except
, RETURN_MASK_ALL
)
378 value
= value_from_contents_and_address (type
, NULL
, address
);
380 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
382 result
= vlscm_scm_from_value (value
);
384 do_cleanups (cleanups
);
386 if (gdbscm_is_exception (result
))
387 gdbscm_throw (result
);
391 /* (value-optimized-out? <gdb:value>) -> boolean */
394 gdbscm_value_optimized_out_p (SCM self
)
397 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
398 struct value
*value
= v_smob
->value
;
400 volatile struct gdb_exception except
;
402 TRY_CATCH (except
, RETURN_MASK_ALL
)
404 opt
= value_optimized_out (value
);
406 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
408 return scm_from_bool (opt
);
411 /* (value-address <gdb:value>) -> integer
412 Returns #f if the value doesn't have one. */
415 gdbscm_value_address (SCM self
)
418 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
419 struct value
*value
= v_smob
->value
;
421 if (SCM_UNBNDP (v_smob
->address
))
423 struct value
*res_val
= NULL
;
424 struct cleanup
*cleanup
425 = make_cleanup_value_free_to_mark (value_mark ());
427 volatile struct gdb_exception except
;
429 TRY_CATCH (except
, RETURN_MASK_ALL
)
431 res_val
= value_addr (value
);
433 if (except
.reason
< 0)
434 address
= SCM_BOOL_F
;
436 address
= vlscm_scm_from_value (res_val
);
438 do_cleanups (cleanup
);
440 if (gdbscm_is_exception (address
))
441 gdbscm_throw (address
);
443 v_smob
->address
= address
;
446 return v_smob
->address
;
449 /* (value-dereference <gdb:value>) -> <gdb:value>
450 Given a value of a pointer type, apply the C unary * operator to it. */
453 gdbscm_value_dereference (SCM self
)
456 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
457 struct value
*value
= v_smob
->value
;
459 struct value
*res_val
= NULL
;
460 struct cleanup
*cleanups
;
461 volatile struct gdb_exception except
;
463 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
465 TRY_CATCH (except
, RETURN_MASK_ALL
)
467 res_val
= value_ind (value
);
469 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
471 result
= vlscm_scm_from_value (res_val
);
473 do_cleanups (cleanups
);
475 if (gdbscm_is_exception (result
))
476 gdbscm_throw (result
);
481 /* (value-referenced-value <gdb:value>) -> <gdb:value>
482 Given a value of a reference type, return the value referenced.
483 The difference between this function and gdbscm_value_dereference is that
484 the latter applies * unary operator to a value, which need not always
485 result in the value referenced.
486 For example, for a value which is a reference to an 'int' pointer ('int *'),
487 gdbscm_value_dereference will result in a value of type 'int' while
488 gdbscm_value_referenced_value will result in a value of type 'int *'. */
491 gdbscm_value_referenced_value (SCM self
)
494 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
495 struct value
*value
= v_smob
->value
;
497 struct value
*res_val
= NULL
;
498 struct cleanup
*cleanups
;
499 volatile struct gdb_exception except
;
501 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
503 TRY_CATCH (except
, RETURN_MASK_ALL
)
505 switch (TYPE_CODE (check_typedef (value_type (value
))))
508 res_val
= value_ind (value
);
511 res_val
= coerce_ref (value
);
514 error (_("Trying to get the referenced value from a value which is"
515 " neither a pointer nor a reference"));
518 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
520 result
= vlscm_scm_from_value (res_val
);
522 do_cleanups (cleanups
);
524 if (gdbscm_is_exception (result
))
525 gdbscm_throw (result
);
530 /* (value-type <gdb:value>) -> <gdb:type> */
533 gdbscm_value_type (SCM self
)
536 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
537 struct value
*value
= v_smob
->value
;
539 if (SCM_UNBNDP (v_smob
->type
))
540 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
545 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
548 gdbscm_value_dynamic_type (SCM self
)
551 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
552 struct value
*value
= v_smob
->value
;
553 struct type
*type
= NULL
;
554 volatile struct gdb_exception except
;
556 if (! SCM_UNBNDP (v_smob
->type
))
557 return v_smob
->dynamic_type
;
559 TRY_CATCH (except
, RETURN_MASK_ALL
)
561 struct cleanup
*cleanup
562 = make_cleanup_value_free_to_mark (value_mark ());
564 type
= value_type (value
);
565 CHECK_TYPEDEF (type
);
567 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
568 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
569 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_CLASS
))
571 struct value
*target
;
572 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
575 target
= value_ind (value
);
577 target
= coerce_ref (value
);
578 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
583 type
= lookup_pointer_type (type
);
585 type
= lookup_reference_type (type
);
588 else if (TYPE_CODE (type
) == TYPE_CODE_CLASS
)
589 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
592 /* Re-use object's static type. */
596 do_cleanups (cleanup
);
598 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
601 v_smob
->dynamic_type
= gdbscm_value_type (self
);
603 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
605 return v_smob
->dynamic_type
;
608 /* A helper function that implements the various cast operators. */
611 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
612 const char *func_name
)
615 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
616 struct value
*value
= v_smob
->value
;
618 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
619 struct type
*type
= tyscm_type_smob_type (t_smob
);
621 struct value
*res_val
= NULL
;
622 struct cleanup
*cleanups
;
623 volatile struct gdb_exception except
;
625 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
627 TRY_CATCH (except
, RETURN_MASK_ALL
)
629 if (op
== UNOP_DYNAMIC_CAST
)
630 res_val
= value_dynamic_cast (type
, value
);
631 else if (op
== UNOP_REINTERPRET_CAST
)
632 res_val
= value_reinterpret_cast (type
, value
);
635 gdb_assert (op
== UNOP_CAST
);
636 res_val
= value_cast (type
, value
);
639 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
641 gdb_assert (res_val
!= NULL
);
642 result
= vlscm_scm_from_value (res_val
);
644 do_cleanups (cleanups
);
646 if (gdbscm_is_exception (result
))
647 gdbscm_throw (result
);
652 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
655 gdbscm_value_cast (SCM self
, SCM new_type
)
657 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
660 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
663 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
665 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
668 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
671 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
673 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
676 /* (value-field <gdb:value> string) -> <gdb:value>
677 Given string name of an element inside structure, return its <gdb:value>
681 gdbscm_value_field (SCM self
, SCM field_scm
)
684 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
685 struct value
*value
= v_smob
->value
;
687 struct value
*res_val
= NULL
;
689 struct cleanup
*cleanups
;
690 volatile struct gdb_exception except
;
692 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
695 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
697 field
= gdbscm_scm_to_c_string (field_scm
);
698 make_cleanup (xfree
, field
);
700 TRY_CATCH (except
, RETURN_MASK_ALL
)
702 struct value
*tmp
= value
;
704 res_val
= value_struct_elt (&tmp
, NULL
, field
, NULL
, NULL
);
706 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
708 gdb_assert (res_val
!= NULL
);
709 result
= vlscm_scm_from_value (res_val
);
711 do_cleanups (cleanups
);
713 if (gdbscm_is_exception (result
))
714 gdbscm_throw (result
);
719 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
720 Return the specified value in an array. */
723 gdbscm_value_subscript (SCM self
, SCM index_scm
)
726 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
727 struct value
*value
= v_smob
->value
;
728 struct value
*index
= NULL
;
729 struct value
*res_val
= NULL
;
730 struct type
*type
= value_type (value
);
731 struct gdbarch
*gdbarch
;
732 SCM result
, except_scm
;
733 struct cleanup
*cleanups
;
734 volatile struct gdb_exception except
;
736 /* The sequencing here, as everywhere else, is important.
737 We can't have existing cleanups when a Scheme exception is thrown. */
739 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
740 gdbarch
= get_type_arch (type
);
742 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
744 index
= vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
746 gdbarch
, current_language
);
749 do_cleanups (cleanups
);
750 gdbscm_throw (except_scm
);
753 TRY_CATCH (except
, RETURN_MASK_ALL
)
755 struct value
*tmp
= value
;
757 /* Assume we are attempting an array access, and let the value code
758 throw an exception if the index has an invalid type.
759 Check the value's type is something that can be accessed via
761 tmp
= coerce_ref (tmp
);
762 type
= check_typedef (value_type (tmp
));
763 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
764 && TYPE_CODE (type
) != TYPE_CODE_PTR
)
765 error (_("Cannot subscript requested type"));
767 res_val
= value_subscript (tmp
, value_as_long (index
));
769 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
771 gdb_assert (res_val
!= NULL
);
772 result
= vlscm_scm_from_value (res_val
);
774 do_cleanups (cleanups
);
776 if (gdbscm_is_exception (result
))
777 gdbscm_throw (result
);
782 /* (value-call <gdb:value> arg-list) -> <gdb:value>
783 Perform an inferior function call on the value. */
786 gdbscm_value_call (SCM self
, SCM args
)
789 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
790 struct value
*function
= v_smob
->value
;
791 struct value
*mark
= value_mark ();
792 struct type
*ftype
= NULL
;
794 struct value
**vargs
= NULL
;
795 SCM result
= SCM_BOOL_F
;
796 volatile struct gdb_exception except
;
798 TRY_CATCH (except
, RETURN_MASK_ALL
)
800 ftype
= check_typedef (value_type (function
));
802 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
804 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
806 _("function (value of TYPE_CODE_FUNC)"));
808 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
809 SCM_ARG2
, FUNC_NAME
, _("list"));
811 args_count
= scm_ilength (args
);
814 struct gdbarch
*gdbarch
= get_current_arch ();
815 const struct language_defn
*language
= current_language
;
819 vargs
= alloca (sizeof (struct value
*) * args_count
);
820 for (i
= 0; i
< args_count
; i
++)
822 SCM arg
= scm_car (args
);
824 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
825 GDBSCM_ARG_NONE
, arg
,
828 if (vargs
[i
] == NULL
)
829 gdbscm_throw (except_scm
);
831 args
= scm_cdr (args
);
833 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
836 TRY_CATCH (except
, RETURN_MASK_ALL
)
838 struct cleanup
*cleanup
= make_cleanup_value_free_to_mark (mark
);
839 struct value
*return_value
;
841 return_value
= call_function_by_hand (function
, args_count
, vargs
);
842 result
= vlscm_scm_from_value (return_value
);
843 do_cleanups (cleanup
);
845 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
847 if (gdbscm_is_exception (result
))
848 gdbscm_throw (result
);
853 /* (value->bytevector <gdb:value>) -> bytevector */
856 gdbscm_value_to_bytevector (SCM self
)
859 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
860 struct value
*value
= v_smob
->value
;
863 const gdb_byte
*contents
= NULL
;
865 volatile struct gdb_exception except
;
867 type
= value_type (value
);
869 TRY_CATCH (except
, RETURN_MASK_ALL
)
871 CHECK_TYPEDEF (type
);
872 length
= TYPE_LENGTH (type
);
873 contents
= value_contents (value
);
875 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
877 bv
= scm_c_make_bytevector (length
);
878 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
883 /* Helper function to determine if a type is "int-like". */
886 is_intlike (struct type
*type
, int ptr_ok
)
888 return (TYPE_CODE (type
) == TYPE_CODE_INT
889 || TYPE_CODE (type
) == TYPE_CODE_ENUM
890 || TYPE_CODE (type
) == TYPE_CODE_BOOL
891 || TYPE_CODE (type
) == TYPE_CODE_CHAR
892 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
895 /* (value->bool <gdb:value>) -> boolean
896 Throws an error if the value is not integer-like. */
899 gdbscm_value_to_bool (SCM self
)
902 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
903 struct value
*value
= v_smob
->value
;
906 volatile struct gdb_exception except
;
908 type
= value_type (value
);
910 TRY_CATCH (except
, RETURN_MASK_ALL
)
912 CHECK_TYPEDEF (type
);
914 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
916 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
917 _("integer-like gdb value"));
919 TRY_CATCH (except
, RETURN_MASK_ALL
)
921 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
922 l
= value_as_address (value
);
924 l
= value_as_long (value
);
926 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
928 return scm_from_bool (l
!= 0);
931 /* (value->integer <gdb:value>) -> integer
932 Throws an error if the value is not integer-like. */
935 gdbscm_value_to_integer (SCM self
)
938 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
939 struct value
*value
= v_smob
->value
;
942 volatile struct gdb_exception except
;
944 type
= value_type (value
);
946 TRY_CATCH (except
, RETURN_MASK_ALL
)
948 CHECK_TYPEDEF (type
);
950 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
952 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
953 _("integer-like gdb value"));
955 TRY_CATCH (except
, RETURN_MASK_ALL
)
957 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
958 l
= value_as_address (value
);
960 l
= value_as_long (value
);
962 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
964 if (TYPE_UNSIGNED (type
))
965 return gdbscm_scm_from_ulongest (l
);
967 return gdbscm_scm_from_longest (l
);
970 /* (value->real <gdb:value>) -> real
971 Throws an error if the value is not a number. */
974 gdbscm_value_to_real (SCM self
)
977 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
978 struct value
*value
= v_smob
->value
;
981 volatile struct gdb_exception except
;
983 type
= value_type (value
);
985 TRY_CATCH (except
, RETURN_MASK_ALL
)
987 CHECK_TYPEDEF (type
);
989 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
991 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
992 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
994 TRY_CATCH (except
, RETURN_MASK_ALL
)
996 d
= value_as_double (value
);
998 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1000 /* TODO: Is there a better way to check if the value fits? */
1001 if (d
!= (double) d
)
1002 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1003 _("number can't be converted to a double"));
1005 return scm_from_double (d
);
1008 /* (value->string <gdb:value>
1009 [#:encoding encoding]
1010 [#:errors #f | 'error | 'substitute]
1013 Return Unicode string with value's contents, which must be a string.
1015 If ENCODING is not given, the string is assumed to be encoded in
1016 the target's charset.
1018 ERRORS is one of #f, 'error or 'substitute.
1019 An error setting of #f means use the default, which is
1020 Guile's %default-port-conversion-strategy. If the default is not one
1021 of 'error or 'substitute, 'substitute is used.
1022 An error setting of "error" causes an exception to be thrown if there's
1023 a decoding error. An error setting of "substitute" causes invalid
1024 characters to be replaced with "?".
1026 If LENGTH is provided, only fetch string to the length provided.
1027 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1030 gdbscm_value_to_string (SCM self
, SCM rest
)
1033 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1034 struct value
*value
= v_smob
->value
;
1035 const SCM keywords
[] = {
1036 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
1038 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
1039 char *encoding
= NULL
;
1040 SCM errors
= SCM_BOOL_F
;
1042 gdb_byte
*buffer
= NULL
;
1043 const char *la_encoding
= NULL
;
1044 struct type
*char_type
= NULL
;
1046 struct cleanup
*cleanups
;
1047 volatile struct gdb_exception except
;
1049 /* The sequencing here, as everywhere else, is important.
1050 We can't have existing cleanups when a Scheme exception is thrown. */
1052 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1053 &encoding_arg_pos
, &encoding
,
1054 &errors_arg_pos
, &errors
,
1055 &length_arg_pos
, &length
);
1057 cleanups
= make_cleanup (xfree
, encoding
);
1059 if (errors_arg_pos
> 0
1060 && errors
!= SCM_BOOL_F
1061 && !scm_is_eq (errors
, error_symbol
)
1062 && !scm_is_eq (errors
, substitute_symbol
))
1065 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1066 _("invalid error kind"));
1068 do_cleanups (cleanups
);
1069 gdbscm_throw (excp
);
1071 if (errors
== SCM_BOOL_F
)
1072 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1073 /* We don't assume anything about the result of scm_port_conversion_strategy.
1074 From this point on, if errors is not 'errors, use 'substitute. */
1076 TRY_CATCH (except
, RETURN_MASK_ALL
)
1078 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1080 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1082 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1083 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1084 discard_cleanups (cleanups
);
1086 scm_dynwind_begin (0);
1088 gdbscm_dynwind_xfree (encoding
);
1089 gdbscm_dynwind_xfree (buffer
);
1091 result
= scm_from_stringn ((const char *) buffer
,
1092 length
* TYPE_LENGTH (char_type
),
1093 (encoding
!= NULL
&& *encoding
!= '\0'
1096 scm_is_eq (errors
, error_symbol
)
1097 ? SCM_FAILED_CONVERSION_ERROR
1098 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1105 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1106 -> <gdb:lazy-string>
1107 Return a Scheme object representing a lazy_string_object type.
1108 A lazy string is a pointer to a string with an optional encoding and length.
1109 If ENCODING is not given, the target's charset is used.
1110 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1111 length will be set to -1 (first null of appropriate with).
1112 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1115 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1118 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1119 struct value
*value
= v_smob
->value
;
1120 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1121 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1122 char *encoding
= NULL
;
1124 SCM result
= SCM_BOOL_F
; /* -Wall */
1125 struct cleanup
*cleanups
;
1126 volatile struct gdb_exception except
;
1128 /* The sequencing here, as everywhere else, is important.
1129 We can't have existing cleanups when a Scheme exception is thrown. */
1131 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1132 &encoding_arg_pos
, &encoding
,
1133 &length_arg_pos
, &length
);
1135 cleanups
= make_cleanup (xfree
, encoding
);
1137 TRY_CATCH (except
, RETURN_MASK_ALL
)
1139 struct cleanup
*inner_cleanup
1140 = make_cleanup_value_free_to_mark (value_mark ());
1142 if (TYPE_CODE (value_type (value
)) == TYPE_CODE_PTR
)
1143 value
= value_ind (value
);
1145 result
= lsscm_make_lazy_string (value_address (value
), length
,
1146 encoding
, value_type (value
));
1148 do_cleanups (inner_cleanup
);
1150 do_cleanups (cleanups
);
1151 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1153 if (gdbscm_is_exception (result
))
1154 gdbscm_throw (result
);
1159 /* (value-lazy? <gdb:value>) -> boolean */
1162 gdbscm_value_lazy_p (SCM self
)
1165 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1166 struct value
*value
= v_smob
->value
;
1168 return scm_from_bool (value_lazy (value
));
1171 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1174 gdbscm_value_fetch_lazy_x (SCM self
)
1177 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1178 struct value
*value
= v_smob
->value
;
1179 volatile struct gdb_exception except
;
1181 TRY_CATCH (except
, RETURN_MASK_ALL
)
1183 if (value_lazy (value
))
1184 value_fetch_lazy (value
);
1186 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1188 return SCM_UNSPECIFIED
;
1191 /* (value-print <gdb:value>) -> string */
1194 gdbscm_value_print (SCM self
)
1197 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1198 struct value
*value
= v_smob
->value
;
1199 struct value_print_options opts
;
1202 volatile struct gdb_exception except
;
1204 get_user_print_options (&opts
);
1207 TRY_CATCH (except
, RETURN_MASK_ALL
)
1209 struct ui_file
*stb
= mem_fileopen ();
1210 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
1212 common_val_print (value
, stb
, 0, &opts
, current_language
);
1213 s
= ui_file_xstrdup (stb
, NULL
);
1215 do_cleanups (old_chain
);
1217 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1219 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1220 throw an error if the encoding fails.
1221 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1222 override the default port conversion handler because contrary to
1223 documentation it doesn't necessarily free the input string. */
1224 result
= scm_from_stringn (s
, strlen (s
), host_charset (),
1225 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1231 /* (parse-and-eval string) -> <gdb:value>
1232 Parse a string and evaluate the string as an expression. */
1235 gdbscm_parse_and_eval (SCM expr_scm
)
1238 struct value
*res_val
= NULL
;
1240 struct cleanup
*cleanups
;
1241 volatile struct gdb_exception except
;
1243 /* The sequencing here, as everywhere else, is important.
1244 We can't have existing cleanups when a Scheme exception is thrown. */
1246 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1247 expr_scm
, &expr_str
);
1249 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
1250 make_cleanup (xfree
, expr_str
);
1252 TRY_CATCH (except
, RETURN_MASK_ALL
)
1254 res_val
= parse_and_eval (expr_str
);
1256 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1258 gdb_assert (res_val
!= NULL
);
1259 result
= vlscm_scm_from_value (res_val
);
1261 do_cleanups (cleanups
);
1263 if (gdbscm_is_exception (result
))
1264 gdbscm_throw (result
);
1269 /* (history-ref integer) -> <gdb:value>
1270 Return the specified value from GDB's value history. */
1273 gdbscm_history_ref (SCM index
)
1276 struct value
*res_val
= NULL
; /* Initialize to appease gcc warning. */
1277 volatile struct gdb_exception except
;
1279 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1281 TRY_CATCH (except
, RETURN_MASK_ALL
)
1283 res_val
= access_value_history (i
);
1285 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1287 return vlscm_scm_from_value (res_val
);
1290 /* (history-append! <gdb:value>) -> index
1291 Append VALUE to GDB's value history. Return its index in the history. */
1294 gdbscm_history_append_x (SCM value
)
1298 volatile struct gdb_exception except
;
1300 v
= vlscm_scm_to_value (value
);
1302 TRY_CATCH (except
, RETURN_MASK_ALL
)
1304 res_index
= record_latest_value (v
);
1306 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1308 return scm_from_int (res_index
);
1311 /* Initialize the Scheme value code. */
1313 static const scheme_function value_functions
[] =
1315 { "value?", 1, 0, 0, gdbscm_value_p
,
1317 Return #t if the object is a <gdb:value> object." },
1319 { "make-value", 1, 0, 1, gdbscm_make_value
,
1321 Create a <gdb:value> representing object.\n\
1322 Typically this is used to convert numbers and strings to\n\
1323 <gdb:value> objects.\n\
1325 Arguments: object [#:type <gdb:type>]" },
1327 { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p
,
1329 Return #t if the value has been optimizd out." },
1331 { "value-address", 1, 0, 0, gdbscm_value_address
,
1333 Return the address of the value." },
1335 { "value-type", 1, 0, 0, gdbscm_value_type
,
1337 Return the type of the value." },
1339 { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type
,
1341 Return the dynamic type of the value." },
1343 { "value-cast", 2, 0, 0, gdbscm_value_cast
,
1345 Cast the value to the supplied type.\n\
1347 Arguments: <gdb:value> <gdb:type>" },
1349 { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast
,
1351 Cast the value to the supplied type, as if by the C++\n\
1352 dynamic_cast operator.\n\
1354 Arguments: <gdb:value> <gdb:type>" },
1356 { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast
,
1358 Cast the value to the supplied type, as if by the C++\n\
1359 reinterpret_cast operator.\n\
1361 Arguments: <gdb:value> <gdb:type>" },
1363 { "value-dereference", 1, 0, 0, gdbscm_value_dereference
,
1365 Return the result of applying the C unary * operator to the value." },
1367 { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value
,
1369 Given a value of a reference type, return the value referenced.\n\
1370 The difference between this function and value-dereference is that\n\
1371 the latter applies * unary operator to a value, which need not always\n\
1372 result in the value referenced.\n\
1373 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1374 value-dereference will result in a value of type 'int' while\n\
1375 value-referenced-value will result in a value of type 'int *'." },
1377 { "value-field", 2, 0, 0, gdbscm_value_field
,
1379 Return the specified field of the value.\n\
1381 Arguments: <gdb:value> string" },
1383 { "value-subscript", 2, 0, 0, gdbscm_value_subscript
,
1385 Return the value of the array at the specified index.\n\
1387 Arguments: <gdb:value> integer" },
1389 { "value-call", 2, 0, 0, gdbscm_value_call
,
1391 Perform an inferior function call taking the value as a pointer to the\n\
1392 function to call.\n\
1393 Each element of the argument list must be a <gdb:value> object or an object\n\
1394 that can be converted to one.\n\
1395 The result is the value returned by the function.\n\
1397 Arguments: <gdb:value> arg-list" },
1399 { "value->bool", 1, 0, 0, gdbscm_value_to_bool
,
1401 Return the Scheme boolean representing the GDB value.\n\
1402 The value must be \"integer like\". Pointers are ok." },
1404 { "value->integer", 1, 0, 0, gdbscm_value_to_integer
,
1406 Return the Scheme integer representing the GDB value.\n\
1407 The value must be \"integer like\". Pointers are ok." },
1409 { "value->real", 1, 0, 0, gdbscm_value_to_real
,
1411 Return the Scheme real number representing the GDB value.\n\
1412 The value must be a number." },
1414 { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector
,
1416 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1417 No transformation, endian or otherwise, is performed." },
1419 { "value->string", 1, 0, 1, gdbscm_value_to_string
,
1421 Return the Unicode string of the value's contents.\n\
1422 If ENCODING is not given, the string is assumed to be encoded in\n\
1423 the target's charset.\n\
1424 An error setting \"error\" causes an exception to be thrown if there's\n\
1425 a decoding error. An error setting of \"substitute\" causes invalid\n\
1426 characters to be replaced with \"?\". The default is \"error\".\n\
1427 If LENGTH is provided, only fetch string to the length provided.\n\
1429 Arguments: <gdb:value>\n\
1430 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1431 [#:length length]" },
1433 { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string
,
1435 Return a Scheme object representing a lazily fetched Unicode string\n\
1436 of the value's contents.\n\
1437 If ENCODING is not given, the string is assumed to be encoded in\n\
1438 the target's charset.\n\
1439 If LENGTH is provided, only fetch string to the length provided.\n\
1441 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1443 { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p
,
1445 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1446 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1449 { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value
,
1451 Create a <gdb:value> that will be lazily fetched from the target.\n\
1453 Arguments: <gdb:type> address" },
1455 { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x
,
1457 Fetch the value from the inferior, if it was lazy.\n\
1458 The result is \"unspecified\"." },
1460 { "value-print", 1, 0, 0, gdbscm_value_print
,
1462 Return the string representation (print form) of the value." },
1464 { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval
,
1466 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1468 { "history-ref", 1, 0, 0, gdbscm_history_ref
,
1470 Return the specified value from GDB's value history." },
1472 { "history-append!", 1, 0, 0, gdbscm_history_append_x
,
1474 Append the specified value onto GDB's value history." },
1480 gdbscm_initialize_values (void)
1482 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1483 sizeof (value_smob
));
1484 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1485 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1486 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1488 gdbscm_define_functions (value_functions
, 1);
1490 type_keyword
= scm_from_latin1_keyword ("type");
1491 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1492 errors_keyword
= scm_from_latin1_keyword ("errors");
1493 length_keyword
= scm_from_latin1_keyword ("length");
1495 error_symbol
= scm_from_latin1_symbol ("error");
1496 escape_symbol
= scm_from_latin1_symbol ("escape");
1497 substitute_symbol
= scm_from_latin1_symbol ("substitute");