123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661 |
- /* Scheme interface to architecture.
- Copyright (C) 2014-2022 Free Software Foundation, Inc.
- This file is part of GDB.
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
- /* See README file in this directory for implementation notes, coding
- conventions, et.al. */
- #include "defs.h"
- #include "charset.h"
- #include "gdbarch.h"
- #include "arch-utils.h"
- #include "guile-internal.h"
- /* The <gdb:arch> smob. */
- struct arch_smob
- {
- /* This always appears first. */
- gdb_smob base;
- struct gdbarch *gdbarch;
- };
- static const char arch_smob_name[] = "gdb:arch";
- /* The tag Guile knows the arch smob by. */
- static scm_t_bits arch_smob_tag;
- static struct gdbarch_data *arch_object_data = NULL;
- static int arscm_is_arch (SCM);
- /* Administrivia for arch smobs. */
- /* The smob "print" function for <gdb:arch>. */
- static int
- arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
- {
- arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
- struct gdbarch *gdbarch = a_smob->gdbarch;
- gdbscm_printf (port, "#<%s", arch_smob_name);
- gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
- scm_puts (">", port);
- scm_remember_upto_here_1 (self);
- /* Non-zero means success. */
- return 1;
- }
- /* Low level routine to create a <gdb:arch> object for GDBARCH. */
- static SCM
- arscm_make_arch_smob (struct gdbarch *gdbarch)
- {
- arch_smob *a_smob = (arch_smob *)
- scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
- SCM a_scm;
- a_smob->gdbarch = gdbarch;
- a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
- gdbscm_init_gsmob (&a_smob->base);
- return a_scm;
- }
- /* Return the gdbarch field of A_SMOB. */
- struct gdbarch *
- arscm_get_gdbarch (arch_smob *a_smob)
- {
- return a_smob->gdbarch;
- }
- /* Return non-zero if SCM is an architecture smob. */
- static int
- arscm_is_arch (SCM scm)
- {
- return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
- }
- /* (arch? object) -> boolean */
- static SCM
- gdbscm_arch_p (SCM scm)
- {
- return scm_from_bool (arscm_is_arch (scm));
- }
- /* Associates an arch_object with GDBARCH as gdbarch_data via the gdbarch
- post init registration mechanism (gdbarch_data_register_post_init). */
- static void *
- arscm_object_data_init (struct gdbarch *gdbarch)
- {
- SCM arch_scm = arscm_make_arch_smob (gdbarch);
- /* This object lasts the duration of the GDB session, so there is no
- call to scm_gc_unprotect_object for it. */
- scm_gc_protect_object (arch_scm);
- return (void *) arch_scm;
- }
- /* Return the <gdb:arch> object corresponding to GDBARCH.
- The object is cached in GDBARCH so this is simple. */
- SCM
- arscm_scm_from_arch (struct gdbarch *gdbarch)
- {
- SCM a_scm = (SCM) gdbarch_data (gdbarch, arch_object_data);
- return a_scm;
- }
- /* Return the <gdb:arch> smob in SELF.
- Throws an exception if SELF is not a <gdb:arch> object. */
- static SCM
- arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
- {
- SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
- arch_smob_name);
- return self;
- }
- /* Return a pointer to the arch smob of SELF.
- Throws an exception if SELF is not a <gdb:arch> object. */
- arch_smob *
- arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
- {
- SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
- arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
- return a_smob;
- }
- /* Arch methods. */
- /* (current-arch) -> <gdb:arch>
- Return the architecture of the currently selected stack frame,
- if there is one, or the current target if there isn't. */
- static SCM
- gdbscm_current_arch (void)
- {
- return arscm_scm_from_arch (get_current_arch ());
- }
- /* (arch-name <gdb:arch>) -> string
- Return the name of the architecture as a string value. */
- static SCM
- gdbscm_arch_name (SCM self)
- {
- arch_smob *a_smob
- = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct gdbarch *gdbarch = a_smob->gdbarch;
- const char *name;
- name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
- return gdbscm_scm_from_c_string (name);
- }
- /* (arch-charset <gdb:arch>) -> string */
- static SCM
- gdbscm_arch_charset (SCM self)
- {
- arch_smob *a_smob
- =arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct gdbarch *gdbarch = a_smob->gdbarch;
- return gdbscm_scm_from_c_string (target_charset (gdbarch));
- }
- /* (arch-wide-charset <gdb:arch>) -> string */
- static SCM
- gdbscm_arch_wide_charset (SCM self)
- {
- arch_smob *a_smob
- = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
- struct gdbarch *gdbarch = a_smob->gdbarch;
- return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
- }
- /* Builtin types.
- The order the types are defined here follows the order in
- struct builtin_type. */
- /* Helper routine to return a builtin type for <gdb:arch> object SELF.
- OFFSET is offsetof (builtin_type, the_type).
- Throws an exception if SELF is not a <gdb:arch> object. */
- static const struct builtin_type *
- gdbscm_arch_builtin_type (SCM self, const char *func_name)
- {
- arch_smob *a_smob
- = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
- struct gdbarch *gdbarch = a_smob->gdbarch;
- return builtin_type (gdbarch);
- }
- /* (arch-void-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_void_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
- return tyscm_scm_from_type (type);
- }
- /* (arch-char-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_char_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
- return tyscm_scm_from_type (type);
- }
- /* (arch-short-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_short_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
- return tyscm_scm_from_type (type);
- }
- /* (arch-int-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_int_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
- return tyscm_scm_from_type (type);
- }
- /* (arch-long-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_long_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
- return tyscm_scm_from_type (type);
- }
- /* (arch-schar-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_schar_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uchar_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
- return tyscm_scm_from_type (type);
- }
- /* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_ushort_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uint-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uint_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
- return tyscm_scm_from_type (type);
- }
- /* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_ulong_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
- return tyscm_scm_from_type (type);
- }
- /* (arch-float-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_float_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
- return tyscm_scm_from_type (type);
- }
- /* (arch-double-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_double_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
- return tyscm_scm_from_type (type);
- }
- /* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_longdouble_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
- return tyscm_scm_from_type (type);
- }
- /* (arch-bool-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_bool_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
- return tyscm_scm_from_type (type);
- }
- /* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_longlong_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
- return tyscm_scm_from_type (type);
- }
- /* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_ulonglong_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
- return tyscm_scm_from_type (type);
- }
- /* (arch-int8-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_int8_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uint8_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
- return tyscm_scm_from_type (type);
- }
- /* (arch-int16-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_int16_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uint16_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
- return tyscm_scm_from_type (type);
- }
- /* (arch-int32-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_int32_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uint32_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
- return tyscm_scm_from_type (type);
- }
- /* (arch-int64-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_int64_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
- return tyscm_scm_from_type (type);
- }
- /* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
- static SCM
- gdbscm_arch_uint64_type (SCM self)
- {
- struct type *type
- = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
- return tyscm_scm_from_type (type);
- }
- /* Initialize the Scheme architecture support. */
- static const scheme_function arch_functions[] =
- {
- { "arch?", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_p),
- "\
- Return #t if the object is a <gdb:arch> object." },
- { "current-arch", 0, 0, 0, as_a_scm_t_subr (gdbscm_current_arch),
- "\
- Return the <gdb:arch> object representing the architecture of the\n\
- currently selected stack frame, if there is one, or the architecture of the\n\
- current target if there isn't.\n\
- \n\
- Arguments: none" },
- { "arch-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_name),
- "\
- Return the name of the architecture." },
- { "arch-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_charset),
- "\
- Return name of target character set as a string." },
- { "arch-wide-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_wide_charset),
- "\
- Return name of target wide character set as a string." },
- { "arch-void-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_void_type),
- "\
- Return the <gdb:type> object for the \"void\" type\n\
- of the architecture." },
- { "arch-char-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_char_type),
- "\
- Return the <gdb:type> object for the \"char\" type\n\
- of the architecture." },
- { "arch-short-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_short_type),
- "\
- Return the <gdb:type> object for the \"short\" type\n\
- of the architecture." },
- { "arch-int-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int_type),
- "\
- Return the <gdb:type> object for the \"int\" type\n\
- of the architecture." },
- { "arch-long-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_long_type),
- "\
- Return the <gdb:type> object for the \"long\" type\n\
- of the architecture." },
- { "arch-schar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_schar_type),
- "\
- Return the <gdb:type> object for the \"signed char\" type\n\
- of the architecture." },
- { "arch-uchar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uchar_type),
- "\
- Return the <gdb:type> object for the \"unsigned char\" type\n\
- of the architecture." },
- { "arch-ushort-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ushort_type),
- "\
- Return the <gdb:type> object for the \"unsigned short\" type\n\
- of the architecture." },
- { "arch-uint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint_type),
- "\
- Return the <gdb:type> object for the \"unsigned int\" type\n\
- of the architecture." },
- { "arch-ulong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ulong_type),
- "\
- Return the <gdb:type> object for the \"unsigned long\" type\n\
- of the architecture." },
- { "arch-float-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_float_type),
- "\
- Return the <gdb:type> object for the \"float\" type\n\
- of the architecture." },
- { "arch-double-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_double_type),
- "\
- Return the <gdb:type> object for the \"double\" type\n\
- of the architecture." },
- { "arch-longdouble-type", 1, 0, 0,
- as_a_scm_t_subr (gdbscm_arch_longdouble_type),
- "\
- Return the <gdb:type> object for the \"long double\" type\n\
- of the architecture." },
- { "arch-bool-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_bool_type),
- "\
- Return the <gdb:type> object for the \"bool\" type\n\
- of the architecture." },
- { "arch-longlong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_longlong_type),
- "\
- Return the <gdb:type> object for the \"long long\" type\n\
- of the architecture." },
- { "arch-ulonglong-type", 1, 0, 0,
- as_a_scm_t_subr (gdbscm_arch_ulonglong_type),
- "\
- Return the <gdb:type> object for the \"unsigned long long\" type\n\
- of the architecture." },
- { "arch-int8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int8_type),
- "\
- Return the <gdb:type> object for the \"int8\" type\n\
- of the architecture." },
- { "arch-uint8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint8_type),
- "\
- Return the <gdb:type> object for the \"uint8\" type\n\
- of the architecture." },
- { "arch-int16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int16_type),
- "\
- Return the <gdb:type> object for the \"int16\" type\n\
- of the architecture." },
- { "arch-uint16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint16_type),
- "\
- Return the <gdb:type> object for the \"uint16\" type\n\
- of the architecture." },
- { "arch-int32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int32_type),
- "\
- Return the <gdb:type> object for the \"int32\" type\n\
- of the architecture." },
- { "arch-uint32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint32_type),
- "\
- Return the <gdb:type> object for the \"uint32\" type\n\
- of the architecture." },
- { "arch-int64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int64_type),
- "\
- Return the <gdb:type> object for the \"int64\" type\n\
- of the architecture." },
- { "arch-uint64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint64_type),
- "\
- Return the <gdb:type> object for the \"uint64\" type\n\
- of the architecture." },
- END_FUNCTIONS
- };
- void
- gdbscm_initialize_arches (void)
- {
- arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
- scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
- gdbscm_define_functions (arch_functions, 1);
- }
- void _initialize_scm_arch ();
- void
- _initialize_scm_arch ()
- {
- arch_object_data
- = gdbarch_data_register_post_init (arscm_object_data_init);
- }
|