1 /* Scheme interface to values.
3 Copyright (C) 2008-2015 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->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 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, NULL);
731 CATCH (except, RETURN_MASK_ALL)
733 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
737 gdb_assert (res_val != NULL);
738 result = vlscm_scm_from_value (res_val);
740 do_cleanups (cleanups);
742 if (gdbscm_is_exception (result))
743 gdbscm_throw (result);
748 /* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
749 Return the specified value in an array. */
752 gdbscm_value_subscript (SCM self, SCM index_scm)
755 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
756 struct value *value = v_smob->value;
757 struct value *index = NULL;
758 struct value *res_val = NULL;
759 struct type *type = value_type (value);
760 struct gdbarch *gdbarch;
761 SCM result, except_scm;
762 struct cleanup *cleanups;
764 /* The sequencing here, as everywhere else, is important.
765 We can't have existing cleanups when a Scheme exception is thrown. */
767 SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
768 gdbarch = get_type_arch (type);
770 cleanups = make_cleanup_value_free_to_mark (value_mark ());
772 index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
774 gdbarch, current_language);
777 do_cleanups (cleanups);
778 gdbscm_throw (except_scm);
783 struct value *tmp = value;
785 /* Assume we are attempting an array access, and let the value code
786 throw an exception if the index has an invalid type.
787 Check the value's type is something that can be accessed via
789 tmp = coerce_ref (tmp);
790 type = check_typedef (value_type (tmp));
791 if (TYPE_CODE (type) != TYPE_CODE_ARRAY
792 && TYPE_CODE (type) != TYPE_CODE_PTR)
793 error (_("Cannot subscript requested type"));
795 res_val = value_subscript (tmp, value_as_long (index));
797 CATCH (except, RETURN_MASK_ALL)
799 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
803 gdb_assert (res_val != NULL);
804 result = vlscm_scm_from_value (res_val);
806 do_cleanups (cleanups);
808 if (gdbscm_is_exception (result))
809 gdbscm_throw (result);
814 /* (value-call <gdb:value> arg-list) -> <gdb:value>
815 Perform an inferior function call on the value. */
818 gdbscm_value_call (SCM self, SCM args)
821 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
822 struct value *function = v_smob->value;
823 struct value *mark = value_mark ();
824 struct type *ftype = NULL;
826 struct value **vargs = NULL;
827 SCM result = SCM_BOOL_F;
831 ftype = check_typedef (value_type (function));
833 CATCH (except, RETURN_MASK_ALL)
835 GDBSCM_HANDLE_GDB_EXCEPTION (except);
839 SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
841 _("function (value of TYPE_CODE_FUNC)"));
843 SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
844 SCM_ARG2, FUNC_NAME, _("list"));
846 args_count = scm_ilength (args);
849 struct gdbarch *gdbarch = get_current_arch ();
850 const struct language_defn *language = current_language;
854 vargs = alloca (sizeof (struct value *) * args_count);
855 for (i = 0; i < args_count; i++)
857 SCM arg = scm_car (args);
859 vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
860 GDBSCM_ARG_NONE, arg,
863 if (vargs[i] == NULL)
864 gdbscm_throw (except_scm);
866 args = scm_cdr (args);
868 gdb_assert (gdbscm_is_true (scm_null_p (args)));
873 struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
874 struct value *return_value;
876 return_value = call_function_by_hand (function, args_count, vargs);
877 result = vlscm_scm_from_value (return_value);
878 do_cleanups (cleanup);
880 CATCH (except, RETURN_MASK_ALL)
882 GDBSCM_HANDLE_GDB_EXCEPTION (except);
886 if (gdbscm_is_exception (result))
887 gdbscm_throw (result);
892 /* (value->bytevector <gdb:value>) -> bytevector */
895 gdbscm_value_to_bytevector (SCM self)
898 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
899 struct value *value = v_smob->value;
902 const gdb_byte *contents = NULL;
905 type = value_type (value);
909 CHECK_TYPEDEF (type);
910 length = TYPE_LENGTH (type);
911 contents = value_contents (value);
913 CATCH (except, RETURN_MASK_ALL)
915 GDBSCM_HANDLE_GDB_EXCEPTION (except);
919 bv = scm_c_make_bytevector (length);
920 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
925 /* Helper function to determine if a type is "int-like". */
928 is_intlike (struct type *type, int ptr_ok)
930 return (TYPE_CODE (type) == TYPE_CODE_INT
931 || TYPE_CODE (type) == TYPE_CODE_ENUM
932 || TYPE_CODE (type) == TYPE_CODE_BOOL
933 || TYPE_CODE (type) == TYPE_CODE_CHAR
934 || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
937 /* (value->bool <gdb:value>) -> boolean
938 Throws an error if the value is not integer-like. */
941 gdbscm_value_to_bool (SCM self)
944 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
945 struct value *value = v_smob->value;
949 type = value_type (value);
953 CHECK_TYPEDEF (type);
955 CATCH (except, RETURN_MASK_ALL)
957 GDBSCM_HANDLE_GDB_EXCEPTION (except);
961 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
962 _("integer-like gdb value"));
966 if (TYPE_CODE (type) == TYPE_CODE_PTR)
967 l = value_as_address (value);
969 l = value_as_long (value);
971 CATCH (except, RETURN_MASK_ALL)
973 GDBSCM_HANDLE_GDB_EXCEPTION (except);
977 return scm_from_bool (l != 0);
980 /* (value->integer <gdb:value>) -> integer
981 Throws an error if the value is not integer-like. */
984 gdbscm_value_to_integer (SCM self)
987 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
988 struct value *value = v_smob->value;
992 type = value_type (value);
996 CHECK_TYPEDEF (type);
998 CATCH (except, RETURN_MASK_ALL)
1000 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1004 SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
1005 _("integer-like gdb value"));
1009 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1010 l = value_as_address (value);
1012 l = value_as_long (value);
1014 CATCH (except, RETURN_MASK_ALL)
1016 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1020 if (TYPE_UNSIGNED (type))
1021 return gdbscm_scm_from_ulongest (l);
1023 return gdbscm_scm_from_longest (l);
1026 /* (value->real <gdb:value>) -> real
1027 Throws an error if the value is not a number. */
1030 gdbscm_value_to_real (SCM self)
1033 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1034 struct value *value = v_smob->value;
1038 type = value_type (value);
1042 CHECK_TYPEDEF (type);
1044 CATCH (except, RETURN_MASK_ALL)
1046 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1050 SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
1051 self, SCM_ARG1, FUNC_NAME, _("number"));
1055 d = value_as_double (value);
1057 CATCH (except, RETURN_MASK_ALL)
1059 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1063 /* TODO: Is there a better way to check if the value fits? */
1064 if (d != (double) d)
1065 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1066 _("number can't be converted to a double"));
1068 return scm_from_double (d);
1071 /* (value->string <gdb:value>
1072 [#:encoding encoding]
1073 [#:errors #f | 'error | 'substitute]
1076 Return Unicode string with value's contents, which must be a string.
1078 If ENCODING is not given, the string is assumed to be encoded in
1079 the target's charset.
1081 ERRORS is one of #f, 'error or 'substitute.
1082 An error setting of #f means use the default, which is Guile's
1083 %default-port-conversion-strategy when using Guile >= 2.0.6, or 'error if
1084 using an earlier version of Guile. Earlier versions do not properly
1085 support obtaining the default port conversion strategy.
1086 If the default is not one of 'error or 'substitute, 'substitute is used.
1087 An error setting of "error" causes an exception to be thrown if there's
1088 a decoding error. An error setting of "substitute" causes invalid
1089 characters to be replaced with "?".
1091 If LENGTH is provided, only fetch string to the length provided.
1092 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1095 gdbscm_value_to_string (SCM self, SCM rest)
1098 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1099 struct value *value = v_smob->value;
1100 const SCM keywords[] = {
1101 encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
1103 int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
1104 char *encoding = NULL;
1105 SCM errors = SCM_BOOL_F;
1107 gdb_byte *buffer = NULL;
1108 const char *la_encoding = NULL;
1109 struct type *char_type = NULL;
1111 struct cleanup *cleanups;
1113 /* The sequencing here, as everywhere else, is important.
1114 We can't have existing cleanups when a Scheme exception is thrown. */
1116 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
1117 &encoding_arg_pos, &encoding,
1118 &errors_arg_pos, &errors,
1119 &length_arg_pos, &length);
1121 cleanups = make_cleanup (xfree, encoding);
1123 if (errors_arg_pos > 0
1124 && errors != SCM_BOOL_F
1125 && !scm_is_eq (errors, error_symbol)
1126 && !scm_is_eq (errors, substitute_symbol))
1129 = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
1130 _("invalid error kind"));
1132 do_cleanups (cleanups);
1133 gdbscm_throw (excp);
1135 if (errors == SCM_BOOL_F)
1137 /* N.B. scm_port_conversion_strategy in Guile versions prior to 2.0.6
1138 will throw a Scheme error when passed #f. */
1139 if (gdbscm_guile_version_is_at_least (2, 0, 6))
1140 errors = scm_port_conversion_strategy (SCM_BOOL_F);
1142 errors = error_symbol;
1144 /* We don't assume anything about the result of scm_port_conversion_strategy.
1145 From this point on, if errors is not 'errors, use 'substitute. */
1149 LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
1151 CATCH (except, RETURN_MASK_ALL)
1153 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1157 /* If errors is "error" scm_from_stringn may throw a Scheme exception.
1158 Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
1159 discard_cleanups (cleanups);
1161 scm_dynwind_begin (0);
1163 gdbscm_dynwind_xfree (encoding);
1164 gdbscm_dynwind_xfree (buffer);
1166 result = scm_from_stringn ((const char *) buffer,
1167 length * TYPE_LENGTH (char_type),
1168 (encoding != NULL && *encoding != '\0'
1171 scm_is_eq (errors, error_symbol)
1172 ? SCM_FAILED_CONVERSION_ERROR
1173 : SCM_FAILED_CONVERSION_QUESTION_MARK);
1180 /* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
1181 -> <gdb:lazy-string>
1182 Return a Scheme object representing a lazy_string_object type.
1183 A lazy string is a pointer to a string with an optional encoding and length.
1184 If ENCODING is not given, the target's charset is used.
1185 If LENGTH is provided then the length parameter is set to LENGTH, otherwise
1186 length will be set to -1 (first null of appropriate with).
1187 LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
1190 gdbscm_value_to_lazy_string (SCM self, SCM rest)
1193 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1194 struct value *value = v_smob->value;
1195 const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
1196 int encoding_arg_pos = -1, length_arg_pos = -1;
1197 char *encoding = NULL;
1199 SCM result = SCM_BOOL_F; /* -Wall */
1200 struct cleanup *cleanups;
1201 struct gdb_exception except = exception_none;
1203 /* The sequencing here, as everywhere else, is important.
1204 We can't have existing cleanups when a Scheme exception is thrown. */
1206 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
1207 &encoding_arg_pos, &encoding,
1208 &length_arg_pos, &length);
1210 cleanups = make_cleanup (xfree, encoding);
1214 struct cleanup *inner_cleanup
1215 = make_cleanup_value_free_to_mark (value_mark ());
1217 if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
1218 value = value_ind (value);
1220 result = lsscm_make_lazy_string (value_address (value), length,
1221 encoding, value_type (value));
1223 do_cleanups (inner_cleanup);
1225 CATCH (ex, RETURN_MASK_ALL)
1231 do_cleanups (cleanups);
1232 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1234 if (gdbscm_is_exception (result))
1235 gdbscm_throw (result);
1240 /* (value-lazy? <gdb:value>) -> boolean */
1243 gdbscm_value_lazy_p (SCM self)
1246 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1247 struct value *value = v_smob->value;
1249 return scm_from_bool (value_lazy (value));
1252 /* (value-fetch-lazy! <gdb:value>) -> unspecified */
1255 gdbscm_value_fetch_lazy_x (SCM self)
1258 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1259 struct value *value = v_smob->value;
1263 if (value_lazy (value))
1264 value_fetch_lazy (value);
1266 CATCH (except, RETURN_MASK_ALL)
1268 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1272 return SCM_UNSPECIFIED;
1275 /* (value-print <gdb:value>) -> string */
1278 gdbscm_value_print (SCM self)
1281 = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1282 struct value *value = v_smob->value;
1283 struct value_print_options opts;
1287 get_user_print_options (&opts);
1292 struct ui_file *stb = mem_fileopen ();
1293 struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
1295 common_val_print (value, stb, 0, &opts, current_language);
1296 s = ui_file_xstrdup (stb, NULL);
1298 do_cleanups (old_chain);
1300 CATCH (except, RETURN_MASK_ALL)
1302 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1306 /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
1307 throw an error if the encoding fails.
1308 IWBN to use scm_take_locale_string here, but we'd have to temporarily
1309 override the default port conversion handler because contrary to
1310 documentation it doesn't necessarily free the input string. */
1311 result = scm_from_stringn (s, strlen (s), host_charset (),
1312 SCM_FAILED_CONVERSION_QUESTION_MARK);
1318 /* (parse-and-eval string) -> <gdb:value>
1319 Parse a string and evaluate the string as an expression. */
1322 gdbscm_parse_and_eval (SCM expr_scm)
1325 struct value *res_val = NULL;
1327 struct cleanup *cleanups;
1329 /* The sequencing here, as everywhere else, is important.
1330 We can't have existing cleanups when a Scheme exception is thrown. */
1332 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
1333 expr_scm, &expr_str);
1335 cleanups = make_cleanup_value_free_to_mark (value_mark ());
1336 make_cleanup (xfree, expr_str);
1340 res_val = parse_and_eval (expr_str);
1342 CATCH (except, RETURN_MASK_ALL)
1344 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
1348 gdb_assert (res_val != NULL);
1349 result = vlscm_scm_from_value (res_val);
1351 do_cleanups (cleanups);
1353 if (gdbscm_is_exception (result))
1354 gdbscm_throw (result);
1359 /* (history-ref integer) -> <gdb:value>
1360 Return the specified value from GDB's value history. */
1363 gdbscm_history_ref (SCM index)
1366 struct value *res_val = NULL; /* Initialize to appease gcc warning. */
1368 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
1372 res_val = access_value_history (i);
1374 CATCH (except, RETURN_MASK_ALL)
1376 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1380 return vlscm_scm_from_value (res_val);
1383 /* (history-append! <gdb:value>) -> index
1384 Append VALUE to GDB's value history. Return its index in the history. */
1387 gdbscm_history_append_x (SCM value)
1393 v_smob = vlscm_get_value_smob_arg_unsafe (value, SCM_ARG1, FUNC_NAME);
1398 res_index = record_latest_value (v);
1400 CATCH (except, RETURN_MASK_ALL)
1402 GDBSCM_HANDLE_GDB_EXCEPTION (except);
1406 return scm_from_int (res_index);
1409 /* Initialize the Scheme value code. */
1411 static const scheme_function value_functions[] =
1413 { "value?", 1, 0, 0, gdbscm_value_p,
1415 Return #t if the object is a <gdb:value> object." },
1417 { "make-value", 1, 0, 1, gdbscm_make_value,
1419 Create a <gdb:value> representing object.\n\
1420 Typically this is used to convert numbers and strings to\n\
1421 <gdb:value> objects.\n\
1423 Arguments: object [#:type <gdb:type>]" },
1425 { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
1427 Return #t if the value has been optimizd out." },
1429 { "value-address", 1, 0, 0, gdbscm_value_address,
1431 Return the address of the value." },
1433 { "value-type", 1, 0, 0, gdbscm_value_type,
1435 Return the type of the value." },
1437 { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
1439 Return the dynamic type of the value." },
1441 { "value-cast", 2, 0, 0, gdbscm_value_cast,
1443 Cast the value to the supplied type.\n\
1445 Arguments: <gdb:value> <gdb:type>" },
1447 { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
1449 Cast the value to the supplied type, as if by the C++\n\
1450 dynamic_cast operator.\n\
1452 Arguments: <gdb:value> <gdb:type>" },
1454 { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
1456 Cast the value to the supplied type, as if by the C++\n\
1457 reinterpret_cast operator.\n\
1459 Arguments: <gdb:value> <gdb:type>" },
1461 { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
1463 Return the result of applying the C unary * operator to the value." },
1465 { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
1467 Given a value of a reference type, return the value referenced.\n\
1468 The difference between this function and value-dereference is that\n\
1469 the latter applies * unary operator to a value, which need not always\n\
1470 result in the value referenced.\n\
1471 For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
1472 value-dereference will result in a value of type 'int' while\n\
1473 value-referenced-value will result in a value of type 'int *'." },
1475 { "value-field", 2, 0, 0, gdbscm_value_field,
1477 Return the specified field of the value.\n\
1479 Arguments: <gdb:value> string" },
1481 { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
1483 Return the value of the array at the specified index.\n\
1485 Arguments: <gdb:value> integer" },
1487 { "value-call", 2, 0, 0, gdbscm_value_call,
1489 Perform an inferior function call taking the value as a pointer to the\n\
1490 function to call.\n\
1491 Each element of the argument list must be a <gdb:value> object or an object\n\
1492 that can be converted to one.\n\
1493 The result is the value returned by the function.\n\
1495 Arguments: <gdb:value> arg-list" },
1497 { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
1499 Return the Scheme boolean representing the GDB value.\n\
1500 The value must be \"integer like\". Pointers are ok." },
1502 { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
1504 Return the Scheme integer representing the GDB value.\n\
1505 The value must be \"integer like\". Pointers are ok." },
1507 { "value->real", 1, 0, 0, gdbscm_value_to_real,
1509 Return the Scheme real number representing the GDB value.\n\
1510 The value must be a number." },
1512 { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
1514 Return a Scheme bytevector with the raw contents of the GDB value.\n\
1515 No transformation, endian or otherwise, is performed." },
1517 { "value->string", 1, 0, 1, gdbscm_value_to_string,
1519 Return the Unicode string of the value's contents.\n\
1520 If ENCODING is not given, the string is assumed to be encoded in\n\
1521 the target's charset.\n\
1522 An error setting \"error\" causes an exception to be thrown if there's\n\
1523 a decoding error. An error setting of \"substitute\" causes invalid\n\
1524 characters to be replaced with \"?\". The default is \"error\".\n\
1525 If LENGTH is provided, only fetch string to the length provided.\n\
1527 Arguments: <gdb:value>\n\
1528 [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
1529 [#:length length]" },
1531 { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
1533 Return a Scheme object representing a lazily fetched Unicode string\n\
1534 of the value's contents.\n\
1535 If ENCODING is not given, the string is assumed to be encoded in\n\
1536 the target's charset.\n\
1537 If LENGTH is provided, only fetch string to the length provided.\n\
1539 Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
1541 { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
1543 Return #t if the value is lazy (not fetched yet from the inferior).\n\
1544 A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
1547 { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
1549 Create a <gdb:value> that will be lazily fetched from the target.\n\
1551 Arguments: <gdb:type> address" },
1553 { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
1555 Fetch the value from the inferior, if it was lazy.\n\
1556 The result is \"unspecified\"." },
1558 { "value-print", 1, 0, 0, gdbscm_value_print,
1560 Return the string representation (print form) of the value." },
1562 { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
1564 Evaluates string in gdb and returns the result as a <gdb:value> object." },
1566 { "history-ref", 1, 0, 0, gdbscm_history_ref,
1568 Return the specified value from GDB's value history." },
1570 { "history-append!", 1, 0, 0, gdbscm_history_append_x,
1572 Append the specified value onto GDB's value history." },
1578 gdbscm_initialize_values (void)
1580 value_smob_tag = gdbscm_make_smob_type (value_smob_name,
1581 sizeof (value_smob));
1582 scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
1583 scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
1584 scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
1586 gdbscm_define_functions (value_functions, 1);
1588 type_keyword = scm_from_latin1_keyword ("type");
1589 encoding_keyword = scm_from_latin1_keyword ("encoding");
1590 errors_keyword = scm_from_latin1_keyword ("errors");
1591 length_keyword = scm_from_latin1_keyword ("length");
1593 error_symbol = scm_from_latin1_symbol ("error");
1594 escape_symbol = scm_from_latin1_symbol ("escape");
1595 substitute_symbol = scm_from_latin1_symbol ("substitute");