1 /* Scheme interface to values.
3 Copyright (C) 2008-2016 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
);
145 struct value_print_options opts
;
147 if (pstate
->writingp
)
148 gdbscm_printf (port
, "#<%s ", value_smob_name
);
150 get_user_print_options (&opts
);
153 /* pstate->writingp = zero if invoked by display/~A, and nonzero if
154 invoked by write/~S. What to do here may need to evolve.
155 IWBN if we could pass an argument to format that would we could use
156 instead of writingp. */
157 opts
.raw
= !!pstate
->writingp
;
161 struct ui_file
*stb
= mem_fileopen ();
162 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
164 common_val_print (v_smob
->value
, stb
, 0, &opts
, current_language
);
165 s
= ui_file_xstrdup (stb
, NULL
);
167 do_cleanups (old_chain
);
169 CATCH (except
, RETURN_MASK_ALL
)
171 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
181 if (pstate
->writingp
)
182 scm_puts (">", port
);
184 scm_remember_upto_here_1 (self
);
186 /* Non-zero means success. */
190 /* The smob "equalp" function for <gdb:value>. */
193 vlscm_equal_p_value_smob (SCM v1
, SCM v2
)
195 const value_smob
*v1_smob
= (value_smob
*) SCM_SMOB_DATA (v1
);
196 const value_smob
*v2_smob
= (value_smob
*) SCM_SMOB_DATA (v2
);
201 result
= value_equal (v1_smob
->value
, v2_smob
->value
);
203 CATCH (except
, RETURN_MASK_ALL
)
205 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
209 return scm_from_bool (result
);
212 /* Low level routine to create a <gdb:value> object. */
215 vlscm_make_value_smob (void)
217 value_smob
*v_smob
= (value_smob
*)
218 scm_gc_malloc (sizeof (value_smob
), value_smob_name
);
221 /* These must be filled in by the caller. */
222 v_smob
->value
= NULL
;
226 /* These are lazily computed. */
227 v_smob
->address
= SCM_UNDEFINED
;
228 v_smob
->type
= SCM_UNDEFINED
;
229 v_smob
->dynamic_type
= SCM_UNDEFINED
;
231 v_scm
= scm_new_smob (value_smob_tag
, (scm_t_bits
) v_smob
);
232 gdbscm_init_gsmob (&v_smob
->base
);
237 /* Return non-zero if SCM is a <gdb:value> object. */
240 vlscm_is_value (SCM scm
)
242 return SCM_SMOB_PREDICATE (value_smob_tag
, scm
);
245 /* (value? object) -> boolean */
248 gdbscm_value_p (SCM scm
)
250 return scm_from_bool (vlscm_is_value (scm
));
253 /* Create a new <gdb:value> object that encapsulates VALUE.
254 The value is released from the all_values chain so its lifetime is not
255 bound to the execution of a command. */
258 vlscm_scm_from_value (struct value
*value
)
260 /* N.B. It's important to not cause any side-effects until we know the
261 conversion worked. */
262 SCM v_scm
= vlscm_make_value_smob ();
263 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
265 v_smob
->value
= value
;
266 release_value_or_incref (value
);
267 vlscm_remember_scheme_value (v_smob
);
272 /* Returns the <gdb:value> object in SELF.
273 Throws an exception if SELF is not a <gdb:value> object. */
276 vlscm_get_value_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
278 SCM_ASSERT_TYPE (vlscm_is_value (self
), self
, arg_pos
, func_name
,
284 /* Returns a pointer to the value smob of SELF.
285 Throws an exception if SELF is not a <gdb:value> object. */
288 vlscm_get_value_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
290 SCM v_scm
= vlscm_get_value_arg_unsafe (self
, arg_pos
, func_name
);
291 value_smob
*v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
296 /* Return the value field of V_SCM, an object of type <gdb:value>.
297 This exists so that we don't have to export the struct's contents. */
300 vlscm_scm_to_value (SCM v_scm
)
304 gdb_assert (vlscm_is_value (v_scm
));
305 v_smob
= (value_smob
*) SCM_SMOB_DATA (v_scm
);
306 return v_smob
->value
;
311 /* (make-value x [#:type type]) -> <gdb:value> */
314 gdbscm_make_value (SCM x
, SCM rest
)
316 struct gdbarch
*gdbarch
= get_current_arch ();
317 const struct language_defn
*language
= current_language
;
318 const SCM keywords
[] = { type_keyword
, SCM_BOOL_F
};
319 int type_arg_pos
= -1;
320 SCM type_scm
= SCM_UNDEFINED
;
321 SCM except_scm
, result
;
323 struct type
*type
= NULL
;
325 struct cleanup
*cleanups
;
327 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#O", rest
,
328 &type_arg_pos
, &type_scm
);
330 if (type_arg_pos
> 0)
332 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, type_arg_pos
,
334 type
= tyscm_type_smob_type (t_smob
);
337 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
339 value
= vlscm_convert_typed_value_from_scheme (FUNC_NAME
, SCM_ARG1
, x
,
340 type_arg_pos
, type_scm
, type
,
345 do_cleanups (cleanups
);
346 gdbscm_throw (except_scm
);
349 result
= vlscm_scm_from_value (value
);
351 do_cleanups (cleanups
);
353 if (gdbscm_is_exception (result
))
354 gdbscm_throw (result
);
358 /* (make-lazy-value <gdb:type> address) -> <gdb:value> */
361 gdbscm_make_lazy_value (SCM type_scm
, SCM address_scm
)
366 struct value
*value
= NULL
;
368 struct cleanup
*cleanups
;
370 t_smob
= tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG1
, FUNC_NAME
);
371 type
= tyscm_type_smob_type (t_smob
);
373 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, NULL
, "U",
374 address_scm
, &address
);
376 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
378 /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
379 and future-proofing we do. */
382 value
= value_from_contents_and_address (type
, NULL
, address
);
384 CATCH (except
, RETURN_MASK_ALL
)
386 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
390 result
= vlscm_scm_from_value (value
);
392 do_cleanups (cleanups
);
394 if (gdbscm_is_exception (result
))
395 gdbscm_throw (result
);
399 /* (value-optimized-out? <gdb:value>) -> boolean */
402 gdbscm_value_optimized_out_p (SCM self
)
405 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
406 struct value
*value
= v_smob
->value
;
411 opt
= value_optimized_out (value
);
413 CATCH (except
, RETURN_MASK_ALL
)
415 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
419 return scm_from_bool (opt
);
422 /* (value-address <gdb:value>) -> integer
423 Returns #f if the value doesn't have one. */
426 gdbscm_value_address (SCM self
)
429 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
430 struct value
*value
= v_smob
->value
;
432 if (SCM_UNBNDP (v_smob
->address
))
434 struct value
*res_val
= NULL
;
435 struct cleanup
*cleanup
436 = make_cleanup_value_free_to_mark (value_mark ());
441 res_val
= value_addr (value
);
443 CATCH (except
, RETURN_MASK_ALL
)
445 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
;
476 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
480 res_val
= value_ind (value
);
482 CATCH (except
, RETURN_MASK_ALL
)
484 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
488 result
= vlscm_scm_from_value (res_val
);
490 do_cleanups (cleanups
);
492 if (gdbscm_is_exception (result
))
493 gdbscm_throw (result
);
498 /* (value-referenced-value <gdb:value>) -> <gdb:value>
499 Given a value of a reference type, return the value referenced.
500 The difference between this function and gdbscm_value_dereference is that
501 the latter applies * unary operator to a value, which need not always
502 result in the value referenced.
503 For example, for a value which is a reference to an 'int' pointer ('int *'),
504 gdbscm_value_dereference will result in a value of type 'int' while
505 gdbscm_value_referenced_value will result in a value of type 'int *'. */
508 gdbscm_value_referenced_value (SCM self
)
511 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
512 struct value
*value
= v_smob
->value
;
514 struct value
*res_val
= NULL
;
515 struct cleanup
*cleanups
;
517 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
521 switch (TYPE_CODE (check_typedef (value_type (value
))))
524 res_val
= value_ind (value
);
527 res_val
= coerce_ref (value
);
530 error (_("Trying to get the referenced value from a value which is"
531 " neither a pointer nor a reference"));
534 CATCH (except
, RETURN_MASK_ALL
)
536 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
540 result
= vlscm_scm_from_value (res_val
);
542 do_cleanups (cleanups
);
544 if (gdbscm_is_exception (result
))
545 gdbscm_throw (result
);
550 /* (value-type <gdb:value>) -> <gdb:type> */
553 gdbscm_value_type (SCM self
)
556 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
557 struct value
*value
= v_smob
->value
;
559 if (SCM_UNBNDP (v_smob
->type
))
560 v_smob
->type
= tyscm_scm_from_type (value_type (value
));
565 /* (value-dynamic-type <gdb:value>) -> <gdb:type> */
568 gdbscm_value_dynamic_type (SCM self
)
571 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
572 struct value
*value
= v_smob
->value
;
573 struct type
*type
= NULL
;
575 if (! SCM_UNBNDP (v_smob
->dynamic_type
))
576 return v_smob
->dynamic_type
;
580 struct cleanup
*cleanup
581 = make_cleanup_value_free_to_mark (value_mark ());
583 type
= value_type (value
);
584 type
= check_typedef (type
);
586 if (((TYPE_CODE (type
) == TYPE_CODE_PTR
)
587 || (TYPE_CODE (type
) == TYPE_CODE_REF
))
588 && (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRUCT
))
590 struct value
*target
;
591 int was_pointer
= TYPE_CODE (type
) == TYPE_CODE_PTR
;
594 target
= value_ind (value
);
596 target
= coerce_ref (value
);
597 type
= value_rtti_type (target
, NULL
, NULL
, NULL
);
602 type
= lookup_pointer_type (type
);
604 type
= lookup_reference_type (type
);
607 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
608 type
= value_rtti_type (value
, NULL
, NULL
, NULL
);
611 /* Re-use object's static type. */
615 do_cleanups (cleanup
);
617 CATCH (except
, RETURN_MASK_ALL
)
619 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
624 v_smob
->dynamic_type
= gdbscm_value_type (self
);
626 v_smob
->dynamic_type
= tyscm_scm_from_type (type
);
628 return v_smob
->dynamic_type
;
631 /* A helper function that implements the various cast operators. */
634 vlscm_do_cast (SCM self
, SCM type_scm
, enum exp_opcode op
,
635 const char *func_name
)
638 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
639 struct value
*value
= v_smob
->value
;
641 = tyscm_get_type_smob_arg_unsafe (type_scm
, SCM_ARG2
, FUNC_NAME
);
642 struct type
*type
= tyscm_type_smob_type (t_smob
);
644 struct value
*res_val
= NULL
;
645 struct cleanup
*cleanups
;
647 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
651 if (op
== UNOP_DYNAMIC_CAST
)
652 res_val
= value_dynamic_cast (type
, value
);
653 else if (op
== UNOP_REINTERPRET_CAST
)
654 res_val
= value_reinterpret_cast (type
, value
);
657 gdb_assert (op
== UNOP_CAST
);
658 res_val
= value_cast (type
, value
);
661 CATCH (except
, RETURN_MASK_ALL
)
663 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
667 gdb_assert (res_val
!= NULL
);
668 result
= vlscm_scm_from_value (res_val
);
670 do_cleanups (cleanups
);
672 if (gdbscm_is_exception (result
))
673 gdbscm_throw (result
);
678 /* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
681 gdbscm_value_cast (SCM self
, SCM new_type
)
683 return vlscm_do_cast (self
, new_type
, UNOP_CAST
, FUNC_NAME
);
686 /* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
689 gdbscm_value_dynamic_cast (SCM self
, SCM new_type
)
691 return vlscm_do_cast (self
, new_type
, UNOP_DYNAMIC_CAST
, FUNC_NAME
);
694 /* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
697 gdbscm_value_reinterpret_cast (SCM self
, SCM new_type
)
699 return vlscm_do_cast (self
, new_type
, UNOP_REINTERPRET_CAST
, FUNC_NAME
);
702 /* (value-field <gdb:value> string) -> <gdb:value>
703 Given string name of an element inside structure, return its <gdb:value>
707 gdbscm_value_field (SCM self
, SCM field_scm
)
710 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
711 struct value
*value
= v_smob
->value
;
713 struct value
*res_val
= NULL
;
715 struct cleanup
*cleanups
;
717 SCM_ASSERT_TYPE (scm_is_string (field_scm
), field_scm
, SCM_ARG2
, FUNC_NAME
,
720 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
722 field
= gdbscm_scm_to_c_string (field_scm
);
723 make_cleanup (xfree
, field
);
727 struct value
*tmp
= value
;
729 res_val
= value_struct_elt (&tmp
, NULL
, field
, NULL
,
730 "struct/class/union");
732 CATCH (except
, RETURN_MASK_ALL
)
734 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
738 gdb_assert (res_val
!= NULL
);
739 result
= vlscm_scm_from_value (res_val
);
741 do_cleanups (cleanups
);
743 if (gdbscm_is_exception (result
))
744 gdbscm_throw (result
);
749 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
750 Return the specified value in an array. */
753 gdbscm_value_subscript (SCM self
, SCM index_scm
)
756 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
757 struct value
*value
= v_smob
->value
;
758 struct value
*index
= NULL
;
759 struct value
*res_val
= NULL
;
760 struct type
*type
= value_type (value
);
761 struct gdbarch
*gdbarch
;
762 SCM result
, except_scm
;
763 struct cleanup
*cleanups
;
765 /* The sequencing here, as everywhere else, is important.
766 We can't have existing cleanups when a Scheme exception is thrown. */
768 SCM_ASSERT (type
!= NULL
, self
, SCM_ARG2
, FUNC_NAME
);
769 gdbarch
= get_type_arch (type
);
771 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
773 index
= vlscm_convert_value_from_scheme (FUNC_NAME
, SCM_ARG2
, index_scm
,
775 gdbarch
, current_language
);
778 do_cleanups (cleanups
);
779 gdbscm_throw (except_scm
);
784 struct value
*tmp
= value
;
786 /* Assume we are attempting an array access, and let the value code
787 throw an exception if the index has an invalid type.
788 Check the value's type is something that can be accessed via
790 tmp
= coerce_ref (tmp
);
791 type
= check_typedef (value_type (tmp
));
792 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
793 && TYPE_CODE (type
) != TYPE_CODE_PTR
)
794 error (_("Cannot subscript requested type"));
796 res_val
= value_subscript (tmp
, value_as_long (index
));
798 CATCH (except
, RETURN_MASK_ALL
)
800 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
804 gdb_assert (res_val
!= NULL
);
805 result
= vlscm_scm_from_value (res_val
);
807 do_cleanups (cleanups
);
809 if (gdbscm_is_exception (result
))
810 gdbscm_throw (result
);
815 /* (value-call <gdb:value> arg-list) -> <gdb:value>
816 Perform an inferior function call on the value. */
819 gdbscm_value_call (SCM self
, SCM args
)
822 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
823 struct value
*function
= v_smob
->value
;
824 struct value
*mark
= value_mark ();
825 struct type
*ftype
= NULL
;
827 struct value
**vargs
= NULL
;
828 SCM result
= SCM_BOOL_F
;
832 ftype
= check_typedef (value_type (function
));
834 CATCH (except
, RETURN_MASK_ALL
)
836 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
840 SCM_ASSERT_TYPE (TYPE_CODE (ftype
) == TYPE_CODE_FUNC
, self
,
842 _("function (value of TYPE_CODE_FUNC)"));
844 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args
)), args
,
845 SCM_ARG2
, FUNC_NAME
, _("list"));
847 args_count
= scm_ilength (args
);
850 struct gdbarch
*gdbarch
= get_current_arch ();
851 const struct language_defn
*language
= current_language
;
855 vargs
= XALLOCAVEC (struct value
*, args_count
);
856 for (i
= 0; i
< args_count
; i
++)
858 SCM arg
= scm_car (args
);
860 vargs
[i
] = vlscm_convert_value_from_scheme (FUNC_NAME
,
861 GDBSCM_ARG_NONE
, arg
,
864 if (vargs
[i
] == NULL
)
865 gdbscm_throw (except_scm
);
867 args
= scm_cdr (args
);
869 gdb_assert (gdbscm_is_true (scm_null_p (args
)));
874 struct cleanup
*cleanup
= make_cleanup_value_free_to_mark (mark
);
875 struct value
*return_value
;
877 return_value
= call_function_by_hand (function
, args_count
, vargs
);
878 result
= vlscm_scm_from_value (return_value
);
879 do_cleanups (cleanup
);
881 CATCH (except
, RETURN_MASK_ALL
)
883 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
887 if (gdbscm_is_exception (result
))
888 gdbscm_throw (result
);
893 /* (value->bytevector <gdb:value>) -> bytevector */
896 gdbscm_value_to_bytevector (SCM self
)
899 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
900 struct value
*value
= v_smob
->value
;
903 const gdb_byte
*contents
= NULL
;
906 type
= value_type (value
);
910 type
= check_typedef (type
);
911 length
= TYPE_LENGTH (type
);
912 contents
= value_contents (value
);
914 CATCH (except
, RETURN_MASK_ALL
)
916 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
920 bv
= scm_c_make_bytevector (length
);
921 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), contents
, length
);
926 /* Helper function to determine if a type is "int-like". */
929 is_intlike (struct type
*type
, int ptr_ok
)
931 return (TYPE_CODE (type
) == TYPE_CODE_INT
932 || TYPE_CODE (type
) == TYPE_CODE_ENUM
933 || TYPE_CODE (type
) == TYPE_CODE_BOOL
934 || TYPE_CODE (type
) == TYPE_CODE_CHAR
935 || (ptr_ok
&& TYPE_CODE (type
) == TYPE_CODE_PTR
));
938 /* (value->bool <gdb:value>) -> boolean
939 Throws an error if the value is not integer-like. */
942 gdbscm_value_to_bool (SCM self
)
945 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
946 struct value
*value
= v_smob
->value
;
950 type
= value_type (value
);
954 type
= check_typedef (type
);
956 CATCH (except
, RETURN_MASK_ALL
)
958 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
962 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
963 _("integer-like gdb value"));
967 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
968 l
= value_as_address (value
);
970 l
= value_as_long (value
);
972 CATCH (except
, RETURN_MASK_ALL
)
974 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
978 return scm_from_bool (l
!= 0);
981 /* (value->integer <gdb:value>) -> integer
982 Throws an error if the value is not integer-like. */
985 gdbscm_value_to_integer (SCM self
)
988 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
989 struct value
*value
= v_smob
->value
;
993 type
= value_type (value
);
997 type
= check_typedef (type
);
999 CATCH (except
, RETURN_MASK_ALL
)
1001 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1005 SCM_ASSERT_TYPE (is_intlike (type
, 1), self
, SCM_ARG1
, FUNC_NAME
,
1006 _("integer-like gdb value"));
1010 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1011 l
= value_as_address (value
);
1013 l
= value_as_long (value
);
1015 CATCH (except
, RETURN_MASK_ALL
)
1017 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1021 if (TYPE_UNSIGNED (type
))
1022 return gdbscm_scm_from_ulongest (l
);
1024 return gdbscm_scm_from_longest (l
);
1027 /* (value->real <gdb:value>) -> real
1028 Throws an error if the value is not a number. */
1031 gdbscm_value_to_real (SCM self
)
1034 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1035 struct value
*value
= v_smob
->value
;
1039 type
= value_type (value
);
1043 type
= check_typedef (type
);
1045 CATCH (except
, RETURN_MASK_ALL
)
1047 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1051 SCM_ASSERT_TYPE (is_intlike (type
, 0) || TYPE_CODE (type
) == TYPE_CODE_FLT
,
1052 self
, SCM_ARG1
, FUNC_NAME
, _("number"));
1056 d
= value_as_double (value
);
1058 CATCH (except
, RETURN_MASK_ALL
)
1060 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1064 /* TODO: Is there a better way to check if the value fits? */
1065 if (d
!= (double) d
)
1066 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
,
1067 _("number can't be converted to a double"));
1069 return scm_from_double (d
);
1072 /* (value->string <gdb:value>
1073 [#:encoding encoding]
1074 [#:errors #f | 'error | 'substitute]
1077 Return Unicode string with value's contents, which must be a string.
1079 If ENCODING is not given, the string is assumed to be encoded in
1080 the target's charset.
1082 ERRORS is one of #f, 'error or 'substitute.
1083 An error setting of #f means use the default, which is Guile's
1084 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1085 using an earlier version of Guile. Earlier versions do not properly
1086 support obtaining the default port conversion strategy.
1087 If the default is not one of 'error or 'substitute, 'substitute is used.
1088 An error setting of "error" causes an exception to be thrown if there's
1089 a decoding error. An error setting of "substitute" causes invalid
1090 characters to be replaced with "?".
1092 If LENGTH is provided, only fetch string to the length provided.
1093 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1096 gdbscm_value_to_string (SCM self
, SCM rest
)
1099 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1100 struct value
*value
= v_smob
->value
;
1101 const SCM keywords
[] = {
1102 encoding_keyword
, errors_keyword
, length_keyword
, SCM_BOOL_F
1104 int encoding_arg_pos
= -1, errors_arg_pos
= -1, length_arg_pos
= -1;
1105 char *encoding
= NULL
;
1106 SCM errors
= SCM_BOOL_F
;
1108 gdb_byte
*buffer
= NULL
;
1109 const char *la_encoding
= NULL
;
1110 struct type
*char_type
= NULL
;
1112 struct cleanup
*cleanups
;
1114 /* The sequencing here, as everywhere else, is important.
1115 We can't have existing cleanups when a Scheme exception is thrown. */
1117 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#sOi", rest
,
1118 &encoding_arg_pos
, &encoding
,
1119 &errors_arg_pos
, &errors
,
1120 &length_arg_pos
, &length
);
1122 cleanups
= make_cleanup (xfree
, encoding
);
1124 if (errors_arg_pos
> 0
1125 && errors
!= SCM_BOOL_F
1126 && !scm_is_eq (errors
, error_symbol
)
1127 && !scm_is_eq (errors
, substitute_symbol
))
1130 = gdbscm_make_out_of_range_error (FUNC_NAME
, errors_arg_pos
, errors
,
1131 _("invalid error kind"));
1133 do_cleanups (cleanups
);
1134 gdbscm_throw (excp
);
1136 if (errors
== SCM_BOOL_F
)
1138 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1139 will throw a Scheme error when passed #f. */
1140 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1141 errors
= scm_port_conversion_strategy (SCM_BOOL_F
);
1143 errors
= error_symbol
;
1145 /* We don't assume anything about the result of scm_port_conversion_strategy.
1146 From this point on, if errors is not 'errors, use 'substitute. */
1150 LA_GET_STRING (value
, &buffer
, &length
, &char_type
, &la_encoding
);
1152 CATCH (except
, RETURN_MASK_ALL
)
1154 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1158 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1159 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1160 discard_cleanups (cleanups
);
1162 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
1164 gdbscm_dynwind_xfree (encoding
);
1165 gdbscm_dynwind_xfree (buffer
);
1167 result
= scm_from_stringn ((const char *) buffer
,
1168 length
* TYPE_LENGTH (char_type
),
1169 (encoding
!= NULL
&& *encoding
!= '\0'
1172 scm_is_eq (errors
, error_symbol
)
1173 ? SCM_FAILED_CONVERSION_ERROR
1174 : SCM_FAILED_CONVERSION_QUESTION_MARK
);
1181 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1182 -> <gdb:lazy-string>
1183 Return a Scheme object representing a lazy_string_object type.
1184 A lazy string is a pointer to a string with an optional encoding and length.
1185 If ENCODING is not given, the target's charset is used.
1186 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1187 length will be set to -1 (first null of appropriate with).
1188 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1191 gdbscm_value_to_lazy_string (SCM self
, SCM rest
)
1194 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1195 struct value
*value
= v_smob
->value
;
1196 const SCM keywords
[] = { encoding_keyword
, length_keyword
, SCM_BOOL_F
};
1197 int encoding_arg_pos
= -1, length_arg_pos
= -1;
1198 char *encoding
= NULL
;
1200 SCM result
= SCM_BOOL_F
; /* -Wall */
1201 struct cleanup
*cleanups
;
1202 struct gdb_exception except
= exception_none
;
1204 /* The sequencing here, as everywhere else, is important.
1205 We can't have existing cleanups when a Scheme exception is thrown. */
1207 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG2
, keywords
, "#si", rest
,
1208 &encoding_arg_pos
, &encoding
,
1209 &length_arg_pos
, &length
);
1211 cleanups
= make_cleanup (xfree
, encoding
);
1215 struct cleanup
*inner_cleanup
1216 = make_cleanup_value_free_to_mark (value_mark ());
1218 if (TYPE_CODE (value_type (value
)) == TYPE_CODE_PTR
)
1219 value
= value_ind (value
);
1221 result
= lsscm_make_lazy_string (value_address (value
), length
,
1222 encoding
, value_type (value
));
1224 do_cleanups (inner_cleanup
);
1226 CATCH (ex
, RETURN_MASK_ALL
)
1232 do_cleanups (cleanups
);
1233 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1235 if (gdbscm_is_exception (result
))
1236 gdbscm_throw (result
);
1241 /* (value-lazy? <gdb:value>) -> boolean */
1244 gdbscm_value_lazy_p (SCM self
)
1247 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1248 struct value
*value
= v_smob
->value
;
1250 return scm_from_bool (value_lazy (value
));
1253 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1256 gdbscm_value_fetch_lazy_x (SCM self
)
1259 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1260 struct value
*value
= v_smob
->value
;
1264 if (value_lazy (value
))
1265 value_fetch_lazy (value
);
1267 CATCH (except
, RETURN_MASK_ALL
)
1269 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1273 return SCM_UNSPECIFIED
;
1276 /* (value-print <gdb:value>) -> string */
1279 gdbscm_value_print (SCM self
)
1282 = vlscm_get_value_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1283 struct value
*value
= v_smob
->value
;
1284 struct value_print_options opts
;
1288 get_user_print_options (&opts
);
1293 struct ui_file
*stb
= mem_fileopen ();
1294 struct cleanup
*old_chain
= make_cleanup_ui_file_delete (stb
);
1296 common_val_print (value
, stb
, 0, &opts
, current_language
);
1297 s
= ui_file_xstrdup (stb
, NULL
);
1299 do_cleanups (old_chain
);
1301 CATCH (except
, RETURN_MASK_ALL
)
1303 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1307 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1308 throw an error if the encoding fails.
1309 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1310 override the default port conversion handler because contrary to
1311 documentation it doesn't necessarily free the input string. */
1312 result
= scm_from_stringn (s
, strlen (s
), host_charset (),
1313 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1319 /* (parse-and-eval string) -> <gdb:value>
1320 Parse a string and evaluate the string as an expression. */
1323 gdbscm_parse_and_eval (SCM expr_scm
)
1326 struct value
*res_val
= NULL
;
1328 struct cleanup
*cleanups
;
1330 /* The sequencing here, as everywhere else, is important.
1331 We can't have existing cleanups when a Scheme exception is thrown. */
1333 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "s",
1334 expr_scm
, &expr_str
);
1336 cleanups
= make_cleanup_value_free_to_mark (value_mark ());
1337 make_cleanup (xfree
, expr_str
);
1341 res_val
= parse_and_eval (expr_str
);
1343 CATCH (except
, RETURN_MASK_ALL
)
1345 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except
, cleanups
);
1349 gdb_assert (res_val
!= NULL
);
1350 result
= vlscm_scm_from_value (res_val
);
1352 do_cleanups (cleanups
);
1354 if (gdbscm_is_exception (result
))
1355 gdbscm_throw (result
);
1360 /* (history-ref integer) -> <gdb:value>
1361 Return the specified value from GDB's value history. */
1364 gdbscm_history_ref (SCM index
)
1367 struct value
*res_val
= NULL
; /* Initialize to appease gcc warning. */
1369 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "i", index
, &i
);
1373 res_val
= access_value_history (i
);
1375 CATCH (except
, RETURN_MASK_ALL
)
1377 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1381 return vlscm_scm_from_value (res_val
);
1384 /* (history-append! <gdb:value>) -> index
1385 Append VALUE to GDB's value history. Return its index in the history. */
1388 gdbscm_history_append_x (SCM value
)
1394 v_smob
= vlscm_get_value_smob_arg_unsafe (value
, SCM_ARG1
, FUNC_NAME
);
1399 res_index
= record_latest_value (v
);
1401 CATCH (except
, RETURN_MASK_ALL
)
1403 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
1407 return scm_from_int (res_index
);
1410 /* Initialize the Scheme value code. */
1412 static const scheme_function value_functions
[] =
1414 { "value?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_p
),
1416 Return #t if the object is a <gdb:value> object." },
1418 { "make-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_value
),
1420 Create a <gdb:value> representing object.\n\
1421 Typically this is used to convert numbers and strings to\n\
1422 <gdb:value> objects.\n\
1424 Arguments: object [#:type <gdb:type>]" },
1426 { "value-optimized-out?", 1, 0, 0,
1427 as_a_scm_t_subr (gdbscm_value_optimized_out_p
),
1429 Return #t if the value has been optimizd out." },
1431 { "value-address", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_address
),
1433 Return the address of the value." },
1435 { "value-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_type
),
1437 Return the type of the value." },
1439 { "value-dynamic-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_type
),
1441 Return the dynamic type of the value." },
1443 { "value-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_cast
),
1445 Cast the value to the supplied type.\n\
1447 Arguments: <gdb:value> <gdb:type>" },
1449 { "value-dynamic-cast", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_dynamic_cast
),
1451 Cast the value to the supplied type, as if by the C++\n\
1452 dynamic_cast operator.\n\
1454 Arguments: <gdb:value> <gdb:type>" },
1456 { "value-reinterpret-cast", 2, 0, 0,
1457 as_a_scm_t_subr (gdbscm_value_reinterpret_cast
),
1459 Cast the value to the supplied type, as if by the C++\n\
1460 reinterpret_cast operator.\n\
1462 Arguments: <gdb:value> <gdb:type>" },
1464 { "value-dereference", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_dereference
),
1466 Return the result of applying the C unary * operator to the value." },
1468 { "value-referenced-value", 1, 0, 0,
1469 as_a_scm_t_subr (gdbscm_value_referenced_value
),
1471 Given a value of a reference type, return the value referenced.\n\
1472 The difference between this function and value-dereference is that\n\
1473 the latter applies * unary operator to a value, which need not always\n\
1474 result in the value referenced.\n\
1475 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1476 value-dereference will result in a value of type 'int' while\n\
1477 value-referenced-value will result in a value of type 'int *'." },
1479 { "value-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_field
),
1481 Return the specified field of the value.\n\
1483 Arguments: <gdb:value> string" },
1485 { "value-subscript", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_subscript
),
1487 Return the value of the array at the specified index.\n\
1489 Arguments: <gdb:value> integer" },
1491 { "value-call", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_call
),
1493 Perform an inferior function call taking the value as a pointer to the\n\
1494 function to call.\n\
1495 Each element of the argument list must be a <gdb:value> object or an object\n\
1496 that can be converted to one.\n\
1497 The result is the value returned by the function.\n\
1499 Arguments: <gdb:value> arg-list" },
1501 { "value->bool", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bool
),
1503 Return the Scheme boolean representing the GDB value.\n\
1504 The value must be \"integer like\". Pointers are ok." },
1506 { "value->integer", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_integer
),
1508 Return the Scheme integer representing the GDB value.\n\
1509 The value must be \"integer like\". Pointers are ok." },
1511 { "value->real", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_real
),
1513 Return the Scheme real number representing the GDB value.\n\
1514 The value must be a number." },
1516 { "value->bytevector", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_to_bytevector
),
1518 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1519 No transformation, endian or otherwise, is performed." },
1521 { "value->string", 1, 0, 1, as_a_scm_t_subr (gdbscm_value_to_string
),
1523 Return the Unicode string of the value's contents.\n\
1524 If ENCODING is not given, the string is assumed to be encoded in\n\
1525 the target's charset.\n\
1526 An error setting \"error\" causes an exception to be thrown if there's\n\
1527 a decoding error. An error setting of \"substitute\" causes invalid\n\
1528 characters to be replaced with \"?\". The default is \"error\".\n\
1529 If LENGTH is provided, only fetch string to the length provided.\n\
1531 Arguments: <gdb:value>\n\
1532 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1533 [#:length length]" },
1535 { "value->lazy-string", 1, 0, 1,
1536 as_a_scm_t_subr (gdbscm_value_to_lazy_string
),
1538 Return a Scheme object representing a lazily fetched Unicode string\n\
1539 of the value's contents.\n\
1540 If ENCODING is not given, the string is assumed to be encoded in\n\
1541 the target's charset.\n\
1542 If LENGTH is provided, only fetch string to the length provided.\n\
1544 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1546 { "value-lazy?", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lazy_p
),
1548 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1549 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1552 { "make-lazy-value", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_lazy_value
),
1554 Create a <gdb:value> that will be lazily fetched from the target.\n\
1556 Arguments: <gdb:type> address" },
1558 { "value-fetch-lazy!", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_fetch_lazy_x
),
1560 Fetch the value from the inferior, if it was lazy.\n\
1561 The result is \"unspecified\"." },
1563 { "value-print", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_print
),
1565 Return the string representation (print form) of the value." },
1567 { "parse-and-eval", 1, 0, 0, as_a_scm_t_subr (gdbscm_parse_and_eval
),
1569 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1571 { "history-ref", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_ref
),
1573 Return the specified value from GDB's value history." },
1575 { "history-append!", 1, 0, 0, as_a_scm_t_subr (gdbscm_history_append_x
),
1577 Append the specified value onto GDB's value history." },
1583 gdbscm_initialize_values (void)
1585 value_smob_tag
= gdbscm_make_smob_type (value_smob_name
,
1586 sizeof (value_smob
));
1587 scm_set_smob_free (value_smob_tag
, vlscm_free_value_smob
);
1588 scm_set_smob_print (value_smob_tag
, vlscm_print_value_smob
);
1589 scm_set_smob_equalp (value_smob_tag
, vlscm_equal_p_value_smob
);
1591 gdbscm_define_functions (value_functions
, 1);
1593 type_keyword
= scm_from_latin1_keyword ("type");
1594 encoding_keyword
= scm_from_latin1_keyword ("encoding");
1595 errors_keyword
= scm_from_latin1_keyword ("errors");
1596 length_keyword
= scm_from_latin1_keyword ("length");
1598 error_symbol
= scm_from_latin1_symbol ("error");
1599 escape_symbol
= scm_from_latin1_symbol ("escape");
1600 substitute_symbol
= scm_from_latin1_symbol ("substitute");