1 /* Scheme interface to architecture.
3 Copyright (C) 2014-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. */
26 #include "arch-utils.h"
27 #include "guile-internal.h"
29 /* The <gdb:arch> smob.
30 The typedef for this struct is in guile-internal.h. */
34 /* This always appears first. */
37 struct gdbarch *gdbarch;
40 static const char arch_smob_name[] = "gdb:arch";
42 /* The tag Guile knows the arch smob by. */
43 static scm_t_bits arch_smob_tag;
45 static struct gdbarch_data *arch_object_data = NULL;
47 static int arscm_is_arch (SCM);
49 /* Administrivia for arch smobs. */
51 /* The smob "print" function for <gdb:arch>. */
54 arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
56 arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
57 struct gdbarch *gdbarch = a_smob->gdbarch;
59 gdbscm_printf (port, "#<%s", arch_smob_name);
60 gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
63 scm_remember_upto_here_1 (self);
65 /* Non-zero means success. */
69 /* Low level routine to create a <gdb:arch> object for GDBARCH. */
72 arscm_make_arch_smob (struct gdbarch *gdbarch)
74 arch_smob *a_smob = (arch_smob *)
75 scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
78 a_smob->gdbarch = gdbarch;
79 a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
80 gdbscm_init_gsmob (&a_smob->base);
85 /* Return the gdbarch field of A_SMOB. */
88 arscm_get_gdbarch (arch_smob *a_smob)
90 return a_smob->gdbarch;
93 /* Return non-zero if SCM is an architecture smob. */
96 arscm_is_arch (SCM scm)
98 return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
101 /* (arch? object) -> boolean */
104 gdbscm_arch_p (SCM scm)
106 return scm_from_bool (arscm_is_arch (scm));
109 /* Associates an arch_object with GDBARCH as gdbarch_data via the gdbarch
110 post init registration mechanism (gdbarch_data_register_post_init). */
113 arscm_object_data_init (struct gdbarch *gdbarch)
115 SCM arch_scm = arscm_make_arch_smob (gdbarch);
117 /* This object lasts the duration of the GDB session, so there is no
118 call to scm_gc_unprotect_object for it. */
119 scm_gc_protect_object (arch_scm);
121 return (void *) arch_scm;
124 /* Return the <gdb:arch> object corresponding to GDBARCH.
125 The object is cached in GDBARCH so this is simple. */
128 arscm_scm_from_arch (struct gdbarch *gdbarch)
130 SCM a_scm = (SCM) gdbarch_data (gdbarch, arch_object_data);
135 /* Return the <gdb:arch> smob in SELF.
136 Throws an exception if SELF is not a <gdb:arch> object. */
139 arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
141 SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
147 /* Return a pointer to the arch smob of SELF.
148 Throws an exception if SELF is not a <gdb:arch> object. */
151 arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
153 SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
154 arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
161 /* (current-arch) -> <gdb:arch>
162 Return the architecture of the currently selected stack frame,
163 if there is one, or the current target if there isn't. */
166 gdbscm_current_arch (void)
168 return arscm_scm_from_arch (get_current_arch ());
171 /* (arch-name <gdb:arch>) -> string
172 Return the name of the architecture as a string value. */
175 gdbscm_arch_name (SCM self)
178 = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
179 struct gdbarch *gdbarch = a_smob->gdbarch;
182 name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
184 return gdbscm_scm_from_c_string (name);
187 /* (arch-charset <gdb:arch>) -> string */
190 gdbscm_arch_charset (SCM self)
193 =arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
194 struct gdbarch *gdbarch = a_smob->gdbarch;
196 return gdbscm_scm_from_c_string (target_charset (gdbarch));
199 /* (arch-wide-charset <gdb:arch>) -> string */
202 gdbscm_arch_wide_charset (SCM self)
205 = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
206 struct gdbarch *gdbarch = a_smob->gdbarch;
208 return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
213 The order the types are defined here follows the order in
214 struct builtin_type. */
216 /* Helper routine to return a builtin type for <gdb:arch> object SELF.
217 OFFSET is offsetof (builtin_type, the_type).
218 Throws an exception if SELF is not a <gdb:arch> object. */
220 static const struct builtin_type *
221 gdbscm_arch_builtin_type (SCM self, const char *func_name)
224 = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
225 struct gdbarch *gdbarch = a_smob->gdbarch;
227 return builtin_type (gdbarch);
230 /* (arch-void-type <gdb:arch>) -> <gdb:type> */
233 gdbscm_arch_void_type (SCM self)
236 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
238 return tyscm_scm_from_type (type);
241 /* (arch-char-type <gdb:arch>) -> <gdb:type> */
244 gdbscm_arch_char_type (SCM self)
247 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
249 return tyscm_scm_from_type (type);
252 /* (arch-short-type <gdb:arch>) -> <gdb:type> */
255 gdbscm_arch_short_type (SCM self)
258 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
260 return tyscm_scm_from_type (type);
263 /* (arch-int-type <gdb:arch>) -> <gdb:type> */
266 gdbscm_arch_int_type (SCM self)
269 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
271 return tyscm_scm_from_type (type);
274 /* (arch-long-type <gdb:arch>) -> <gdb:type> */
277 gdbscm_arch_long_type (SCM self)
280 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
282 return tyscm_scm_from_type (type);
285 /* (arch-schar-type <gdb:arch>) -> <gdb:type> */
288 gdbscm_arch_schar_type (SCM self)
291 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
293 return tyscm_scm_from_type (type);
296 /* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
299 gdbscm_arch_uchar_type (SCM self)
302 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
304 return tyscm_scm_from_type (type);
307 /* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
310 gdbscm_arch_ushort_type (SCM self)
313 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
315 return tyscm_scm_from_type (type);
318 /* (arch-uint-type <gdb:arch>) -> <gdb:type> */
321 gdbscm_arch_uint_type (SCM self)
324 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
326 return tyscm_scm_from_type (type);
329 /* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
332 gdbscm_arch_ulong_type (SCM self)
335 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
337 return tyscm_scm_from_type (type);
340 /* (arch-float-type <gdb:arch>) -> <gdb:type> */
343 gdbscm_arch_float_type (SCM self)
346 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
348 return tyscm_scm_from_type (type);
351 /* (arch-double-type <gdb:arch>) -> <gdb:type> */
354 gdbscm_arch_double_type (SCM self)
357 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
359 return tyscm_scm_from_type (type);
362 /* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
365 gdbscm_arch_longdouble_type (SCM self)
368 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
370 return tyscm_scm_from_type (type);
373 /* (arch-bool-type <gdb:arch>) -> <gdb:type> */
376 gdbscm_arch_bool_type (SCM self)
379 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
381 return tyscm_scm_from_type (type);
384 /* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
387 gdbscm_arch_longlong_type (SCM self)
390 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
392 return tyscm_scm_from_type (type);
395 /* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
398 gdbscm_arch_ulonglong_type (SCM self)
401 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
403 return tyscm_scm_from_type (type);
406 /* (arch-int8-type <gdb:arch>) -> <gdb:type> */
409 gdbscm_arch_int8_type (SCM self)
412 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
414 return tyscm_scm_from_type (type);
417 /* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
420 gdbscm_arch_uint8_type (SCM self)
423 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
425 return tyscm_scm_from_type (type);
428 /* (arch-int16-type <gdb:arch>) -> <gdb:type> */
431 gdbscm_arch_int16_type (SCM self)
434 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
436 return tyscm_scm_from_type (type);
439 /* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
442 gdbscm_arch_uint16_type (SCM self)
445 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
447 return tyscm_scm_from_type (type);
450 /* (arch-int32-type <gdb:arch>) -> <gdb:type> */
453 gdbscm_arch_int32_type (SCM self)
456 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
458 return tyscm_scm_from_type (type);
461 /* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
464 gdbscm_arch_uint32_type (SCM self)
467 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
469 return tyscm_scm_from_type (type);
472 /* (arch-int64-type <gdb:arch>) -> <gdb:type> */
475 gdbscm_arch_int64_type (SCM self)
478 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
480 return tyscm_scm_from_type (type);
483 /* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
486 gdbscm_arch_uint64_type (SCM self)
489 = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
491 return tyscm_scm_from_type (type);
494 /* Initialize the Scheme architecture support. */
496 static const scheme_function arch_functions[] =
498 { "arch?", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_p),
500 Return #t if the object is a <gdb:arch> object." },
502 { "current-arch", 0, 0, 0, as_a_scm_t_subr (gdbscm_current_arch),
504 Return the <gdb:arch> object representing the architecture of the\n\
505 currently selected stack frame, if there is one, or the architecture of the\n\
506 current target if there isn't.\n\
510 { "arch-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_name),
512 Return the name of the architecture." },
514 { "arch-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_charset),
516 Return name of target character set as a string." },
518 { "arch-wide-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_wide_charset),
520 Return name of target wide character set as a string." },
522 { "arch-void-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_void_type),
524 Return the <gdb:type> object for the \"void\" type\n\
525 of the architecture." },
527 { "arch-char-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_char_type),
529 Return the <gdb:type> object for the \"char\" type\n\
530 of the architecture." },
532 { "arch-short-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_short_type),
534 Return the <gdb:type> object for the \"short\" type\n\
535 of the architecture." },
537 { "arch-int-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int_type),
539 Return the <gdb:type> object for the \"int\" type\n\
540 of the architecture." },
542 { "arch-long-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_long_type),
544 Return the <gdb:type> object for the \"long\" type\n\
545 of the architecture." },
547 { "arch-schar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_schar_type),
549 Return the <gdb:type> object for the \"signed char\" type\n\
550 of the architecture." },
552 { "arch-uchar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uchar_type),
554 Return the <gdb:type> object for the \"unsigned char\" type\n\
555 of the architecture." },
557 { "arch-ushort-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ushort_type),
559 Return the <gdb:type> object for the \"unsigned short\" type\n\
560 of the architecture." },
562 { "arch-uint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint_type),
564 Return the <gdb:type> object for the \"unsigned int\" type\n\
565 of the architecture." },
567 { "arch-ulong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ulong_type),
569 Return the <gdb:type> object for the \"unsigned long\" type\n\
570 of the architecture." },
572 { "arch-float-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_float_type),
574 Return the <gdb:type> object for the \"float\" type\n\
575 of the architecture." },
577 { "arch-double-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_double_type),
579 Return the <gdb:type> object for the \"double\" type\n\
580 of the architecture." },
582 { "arch-longdouble-type", 1, 0, 0,
583 as_a_scm_t_subr (gdbscm_arch_longdouble_type),
585 Return the <gdb:type> object for the \"long double\" type\n\
586 of the architecture." },
588 { "arch-bool-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_bool_type),
590 Return the <gdb:type> object for the \"bool\" type\n\
591 of the architecture." },
593 { "arch-longlong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_longlong_type),
595 Return the <gdb:type> object for the \"long long\" type\n\
596 of the architecture." },
598 { "arch-ulonglong-type", 1, 0, 0,
599 as_a_scm_t_subr (gdbscm_arch_ulonglong_type),
601 Return the <gdb:type> object for the \"unsigned long long\" type\n\
602 of the architecture." },
604 { "arch-int8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int8_type),
606 Return the <gdb:type> object for the \"int8\" type\n\
607 of the architecture." },
609 { "arch-uint8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint8_type),
611 Return the <gdb:type> object for the \"uint8\" type\n\
612 of the architecture." },
614 { "arch-int16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int16_type),
616 Return the <gdb:type> object for the \"int16\" type\n\
617 of the architecture." },
619 { "arch-uint16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint16_type),
621 Return the <gdb:type> object for the \"uint16\" type\n\
622 of the architecture." },
624 { "arch-int32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int32_type),
626 Return the <gdb:type> object for the \"int32\" type\n\
627 of the architecture." },
629 { "arch-uint32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint32_type),
631 Return the <gdb:type> object for the \"uint32\" type\n\
632 of the architecture." },
634 { "arch-int64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int64_type),
636 Return the <gdb:type> object for the \"int64\" type\n\
637 of the architecture." },
639 { "arch-uint64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint64_type),
641 Return the <gdb:type> object for the \"uint64\" type\n\
642 of the architecture." },
648 gdbscm_initialize_arches (void)
650 arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
651 scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
653 gdbscm_define_functions (arch_functions, 1);
656 = gdbarch_data_register_post_init (arscm_object_data_init);