xref: /netbsd-src/external/gpl3/gdb/dist/gdb/guile/scm-arch.c (revision 9baafaf618f45376757e1e183bcad58952f069c4)
1 /* Scheme interface to architecture.
2 
3    Copyright (C) 2014-2024 Free Software Foundation, Inc.
4 
5    This file is part of GDB.
6 
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.
11 
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.
16 
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/>.  */
19 
20 /* See README file in this directory for implementation notes, coding
21    conventions, et.al.  */
22 
23 #include "charset.h"
24 #include "gdbarch.h"
25 #include "arch-utils.h"
26 #include "guile-internal.h"
27 
28 /* The <gdb:arch> smob.  */
29 
30 struct arch_smob
31 {
32   /* This always appears first.  */
33   gdb_smob base;
34 
35   struct gdbarch *gdbarch;
36 };
37 
38 static const char arch_smob_name[] = "gdb:arch";
39 
40 /* The tag Guile knows the arch smob by.  */
41 static scm_t_bits arch_smob_tag;
42 
43 /* Use a 'void *' here because it isn't guaranteed that SCM is a
44    pointer.  */
45 static const registry<gdbarch>::key<void, gdb::noop_deleter<void>>
46      arch_object_data;
47 
48 static int arscm_is_arch (SCM);
49 
50 /* Administrivia for arch smobs.  */
51 
52 /* The smob "print" function for <gdb:arch>.  */
53 
54 static int
55 arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
56 {
57   arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
58   struct gdbarch *gdbarch = a_smob->gdbarch;
59 
60   gdbscm_printf (port, "#<%s", arch_smob_name);
61   gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
62   scm_puts (">", port);
63 
64   scm_remember_upto_here_1 (self);
65 
66   /* Non-zero means success.  */
67   return 1;
68 }
69 
70 /* Low level routine to create a <gdb:arch> object for GDBARCH.  */
71 
72 static SCM
73 arscm_make_arch_smob (struct gdbarch *gdbarch)
74 {
75   arch_smob *a_smob = (arch_smob *)
76     scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
77   SCM a_scm;
78 
79   a_smob->gdbarch = gdbarch;
80   a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
81   gdbscm_init_gsmob (&a_smob->base);
82 
83   return a_scm;
84 }
85 
86 /* Return the gdbarch field of A_SMOB.  */
87 
88 struct gdbarch *
89 arscm_get_gdbarch (arch_smob *a_smob)
90 {
91   return a_smob->gdbarch;
92 }
93 
94 /* Return non-zero if SCM is an architecture smob.  */
95 
96 static int
97 arscm_is_arch (SCM scm)
98 {
99   return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
100 }
101 
102 /* (arch? object) -> boolean */
103 
104 static SCM
105 gdbscm_arch_p (SCM scm)
106 {
107   return scm_from_bool (arscm_is_arch (scm));
108 }
109 
110 /* Return the <gdb:arch> object corresponding to GDBARCH.
111    The object is cached in GDBARCH so this is simple.  */
112 
113 SCM
114 arscm_scm_from_arch (struct gdbarch *gdbarch)
115 {
116   SCM arch_scm;
117   void *data = arch_object_data.get (gdbarch);
118   if (data == nullptr)
119     {
120       arch_scm = arscm_make_arch_smob (gdbarch);
121 
122       /* This object lasts the duration of the GDB session, so there
123 	 is no call to scm_gc_unprotect_object for it.  */
124       scm_gc_protect_object (arch_scm);
125 
126       arch_object_data.set (gdbarch, (void *) arch_scm);
127     }
128   else
129     arch_scm = (SCM) data;
130 
131   return arch_scm;
132 }
133 
134 /* Return the <gdb:arch> smob in SELF.
135    Throws an exception if SELF is not a <gdb:arch> object.  */
136 
137 static SCM
138 arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
139 {
140   SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
141 		   arch_smob_name);
142 
143   return self;
144 }
145 
146 /* Return a pointer to the arch smob of SELF.
147    Throws an exception if SELF is not a <gdb:arch> object.  */
148 
149 arch_smob *
150 arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
151 {
152   SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
153   arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
154 
155   return a_smob;
156 }
157 
158 /* Arch methods.  */
159 
160 /* (current-arch) -> <gdb:arch>
161    Return the architecture of the currently selected stack frame,
162    if there is one, or the current target if there isn't.  */
163 
164 static SCM
165 gdbscm_current_arch (void)
166 {
167   return arscm_scm_from_arch (get_current_arch ());
168 }
169 
170 /* (arch-name <gdb:arch>) -> string
171    Return the name of the architecture as a string value.  */
172 
173 static SCM
174 gdbscm_arch_name (SCM self)
175 {
176   arch_smob *a_smob
177     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
178   struct gdbarch *gdbarch = a_smob->gdbarch;
179   const char *name;
180 
181   name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
182 
183   return gdbscm_scm_from_c_string (name);
184 }
185 
186 /* (arch-charset <gdb:arch>) -> string */
187 
188 static SCM
189 gdbscm_arch_charset (SCM self)
190 {
191   arch_smob *a_smob
192     =arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
193   struct gdbarch *gdbarch = a_smob->gdbarch;
194 
195   return gdbscm_scm_from_c_string (target_charset (gdbarch));
196 }
197 
198 /* (arch-wide-charset <gdb:arch>) -> string */
199 
200 static SCM
201 gdbscm_arch_wide_charset (SCM self)
202 {
203   arch_smob *a_smob
204     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
205   struct gdbarch *gdbarch = a_smob->gdbarch;
206 
207   return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
208 }
209 
210 /* Builtin types.
211 
212    The order the types are defined here follows the order in
213    struct builtin_type.  */
214 
215 /* Helper routine to return a builtin type for <gdb:arch> object SELF.
216    OFFSET is offsetof (builtin_type, the_type).
217    Throws an exception if SELF is not a <gdb:arch> object.  */
218 
219 static const struct builtin_type *
220 gdbscm_arch_builtin_type (SCM self, const char *func_name)
221 {
222   arch_smob *a_smob
223     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
224   struct gdbarch *gdbarch = a_smob->gdbarch;
225 
226   return builtin_type (gdbarch);
227 }
228 
229 /* (arch-void-type <gdb:arch>) -> <gdb:type> */
230 
231 static SCM
232 gdbscm_arch_void_type (SCM self)
233 {
234   struct type *type
235     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
236 
237   return tyscm_scm_from_type (type);
238 }
239 
240 /* (arch-char-type <gdb:arch>) -> <gdb:type> */
241 
242 static SCM
243 gdbscm_arch_char_type (SCM self)
244 {
245   struct type *type
246     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
247 
248   return tyscm_scm_from_type (type);
249 }
250 
251 /* (arch-short-type <gdb:arch>) -> <gdb:type> */
252 
253 static SCM
254 gdbscm_arch_short_type (SCM self)
255 {
256   struct type *type
257     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
258 
259   return tyscm_scm_from_type (type);
260 }
261 
262 /* (arch-int-type <gdb:arch>) -> <gdb:type> */
263 
264 static SCM
265 gdbscm_arch_int_type (SCM self)
266 {
267   struct type *type
268     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
269 
270   return tyscm_scm_from_type (type);
271 }
272 
273 /* (arch-long-type <gdb:arch>) -> <gdb:type> */
274 
275 static SCM
276 gdbscm_arch_long_type (SCM self)
277 {
278   struct type *type
279     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
280 
281   return tyscm_scm_from_type (type);
282 }
283 
284 /* (arch-schar-type <gdb:arch>) -> <gdb:type> */
285 
286 static SCM
287 gdbscm_arch_schar_type (SCM self)
288 {
289   struct type *type
290     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
291 
292   return tyscm_scm_from_type (type);
293 }
294 
295 /* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
296 
297 static SCM
298 gdbscm_arch_uchar_type (SCM self)
299 {
300   struct type *type
301     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
302 
303   return tyscm_scm_from_type (type);
304 }
305 
306 /* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
307 
308 static SCM
309 gdbscm_arch_ushort_type (SCM self)
310 {
311   struct type *type
312     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
313 
314   return tyscm_scm_from_type (type);
315 }
316 
317 /* (arch-uint-type <gdb:arch>) -> <gdb:type> */
318 
319 static SCM
320 gdbscm_arch_uint_type (SCM self)
321 {
322   struct type *type
323     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
324 
325   return tyscm_scm_from_type (type);
326 }
327 
328 /* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
329 
330 static SCM
331 gdbscm_arch_ulong_type (SCM self)
332 {
333   struct type *type
334     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
335 
336   return tyscm_scm_from_type (type);
337 }
338 
339 /* (arch-float-type <gdb:arch>) -> <gdb:type> */
340 
341 static SCM
342 gdbscm_arch_float_type (SCM self)
343 {
344   struct type *type
345     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
346 
347   return tyscm_scm_from_type (type);
348 }
349 
350 /* (arch-double-type <gdb:arch>) -> <gdb:type> */
351 
352 static SCM
353 gdbscm_arch_double_type (SCM self)
354 {
355   struct type *type
356     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
357 
358   return tyscm_scm_from_type (type);
359 }
360 
361 /* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
362 
363 static SCM
364 gdbscm_arch_longdouble_type (SCM self)
365 {
366   struct type *type
367     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
368 
369   return tyscm_scm_from_type (type);
370 }
371 
372 /* (arch-bool-type <gdb:arch>) -> <gdb:type> */
373 
374 static SCM
375 gdbscm_arch_bool_type (SCM self)
376 {
377   struct type *type
378     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
379 
380   return tyscm_scm_from_type (type);
381 }
382 
383 /* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
384 
385 static SCM
386 gdbscm_arch_longlong_type (SCM self)
387 {
388   struct type *type
389     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
390 
391   return tyscm_scm_from_type (type);
392 }
393 
394 /* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
395 
396 static SCM
397 gdbscm_arch_ulonglong_type (SCM self)
398 {
399   struct type *type
400     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
401 
402   return tyscm_scm_from_type (type);
403 }
404 
405 /* (arch-int8-type <gdb:arch>) -> <gdb:type> */
406 
407 static SCM
408 gdbscm_arch_int8_type (SCM self)
409 {
410   struct type *type
411     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
412 
413   return tyscm_scm_from_type (type);
414 }
415 
416 /* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
417 
418 static SCM
419 gdbscm_arch_uint8_type (SCM self)
420 {
421   struct type *type
422     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
423 
424   return tyscm_scm_from_type (type);
425 }
426 
427 /* (arch-int16-type <gdb:arch>) -> <gdb:type> */
428 
429 static SCM
430 gdbscm_arch_int16_type (SCM self)
431 {
432   struct type *type
433     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
434 
435   return tyscm_scm_from_type (type);
436 }
437 
438 /* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
439 
440 static SCM
441 gdbscm_arch_uint16_type (SCM self)
442 {
443   struct type *type
444     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
445 
446   return tyscm_scm_from_type (type);
447 }
448 
449 /* (arch-int32-type <gdb:arch>) -> <gdb:type> */
450 
451 static SCM
452 gdbscm_arch_int32_type (SCM self)
453 {
454   struct type *type
455     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
456 
457   return tyscm_scm_from_type (type);
458 }
459 
460 /* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
461 
462 static SCM
463 gdbscm_arch_uint32_type (SCM self)
464 {
465   struct type *type
466     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
467 
468   return tyscm_scm_from_type (type);
469 }
470 
471 /* (arch-int64-type <gdb:arch>) -> <gdb:type> */
472 
473 static SCM
474 gdbscm_arch_int64_type (SCM self)
475 {
476   struct type *type
477     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
478 
479   return tyscm_scm_from_type (type);
480 }
481 
482 /* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
483 
484 static SCM
485 gdbscm_arch_uint64_type (SCM self)
486 {
487   struct type *type
488     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
489 
490   return tyscm_scm_from_type (type);
491 }
492 
493 /* Initialize the Scheme architecture support.  */
494 
495 static const scheme_function arch_functions[] =
496 {
497   { "arch?", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_p),
498     "\
499 Return #t if the object is a <gdb:arch> object." },
500 
501   { "current-arch", 0, 0, 0, as_a_scm_t_subr (gdbscm_current_arch),
502     "\
503 Return the <gdb:arch> object representing the architecture of the\n\
504 currently selected stack frame, if there is one, or the architecture of the\n\
505 current target if there isn't.\n\
506 \n\
507   Arguments: none" },
508 
509   { "arch-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_name),
510     "\
511 Return the name of the architecture." },
512 
513   { "arch-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_charset),
514   "\
515 Return name of target character set as a string." },
516 
517   { "arch-wide-charset", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_wide_charset),
518   "\
519 Return name of target wide character set as a string." },
520 
521   { "arch-void-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_void_type),
522     "\
523 Return the <gdb:type> object for the \"void\" type\n\
524 of the architecture." },
525 
526   { "arch-char-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_char_type),
527     "\
528 Return the <gdb:type> object for the \"char\" type\n\
529 of the architecture." },
530 
531   { "arch-short-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_short_type),
532     "\
533 Return the <gdb:type> object for the \"short\" type\n\
534 of the architecture." },
535 
536   { "arch-int-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int_type),
537     "\
538 Return the <gdb:type> object for the \"int\" type\n\
539 of the architecture." },
540 
541   { "arch-long-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_long_type),
542     "\
543 Return the <gdb:type> object for the \"long\" type\n\
544 of the architecture." },
545 
546   { "arch-schar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_schar_type),
547     "\
548 Return the <gdb:type> object for the \"signed char\" type\n\
549 of the architecture." },
550 
551   { "arch-uchar-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uchar_type),
552     "\
553 Return the <gdb:type> object for the \"unsigned char\" type\n\
554 of the architecture." },
555 
556   { "arch-ushort-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ushort_type),
557     "\
558 Return the <gdb:type> object for the \"unsigned short\" type\n\
559 of the architecture." },
560 
561   { "arch-uint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint_type),
562     "\
563 Return the <gdb:type> object for the \"unsigned int\" type\n\
564 of the architecture." },
565 
566   { "arch-ulong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_ulong_type),
567     "\
568 Return the <gdb:type> object for the \"unsigned long\" type\n\
569 of the architecture." },
570 
571   { "arch-float-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_float_type),
572     "\
573 Return the <gdb:type> object for the \"float\" type\n\
574 of the architecture." },
575 
576   { "arch-double-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_double_type),
577     "\
578 Return the <gdb:type> object for the \"double\" type\n\
579 of the architecture." },
580 
581   { "arch-longdouble-type", 1, 0, 0,
582     as_a_scm_t_subr (gdbscm_arch_longdouble_type),
583     "\
584 Return the <gdb:type> object for the \"long double\" type\n\
585 of the architecture." },
586 
587   { "arch-bool-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_bool_type),
588     "\
589 Return the <gdb:type> object for the \"bool\" type\n\
590 of the architecture." },
591 
592   { "arch-longlong-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_longlong_type),
593     "\
594 Return the <gdb:type> object for the \"long long\" type\n\
595 of the architecture." },
596 
597   { "arch-ulonglong-type", 1, 0, 0,
598     as_a_scm_t_subr (gdbscm_arch_ulonglong_type),
599     "\
600 Return the <gdb:type> object for the \"unsigned long long\" type\n\
601 of the architecture." },
602 
603   { "arch-int8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int8_type),
604     "\
605 Return the <gdb:type> object for the \"int8\" type\n\
606 of the architecture." },
607 
608   { "arch-uint8-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint8_type),
609     "\
610 Return the <gdb:type> object for the \"uint8\" type\n\
611 of the architecture." },
612 
613   { "arch-int16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int16_type),
614     "\
615 Return the <gdb:type> object for the \"int16\" type\n\
616 of the architecture." },
617 
618   { "arch-uint16-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint16_type),
619     "\
620 Return the <gdb:type> object for the \"uint16\" type\n\
621 of the architecture." },
622 
623   { "arch-int32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int32_type),
624     "\
625 Return the <gdb:type> object for the \"int32\" type\n\
626 of the architecture." },
627 
628   { "arch-uint32-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint32_type),
629     "\
630 Return the <gdb:type> object for the \"uint32\" type\n\
631 of the architecture." },
632 
633   { "arch-int64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_int64_type),
634     "\
635 Return the <gdb:type> object for the \"int64\" type\n\
636 of the architecture." },
637 
638   { "arch-uint64-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_arch_uint64_type),
639     "\
640 Return the <gdb:type> object for the \"uint64\" type\n\
641 of the architecture." },
642 
643   END_FUNCTIONS
644 };
645 
646 void
647 gdbscm_initialize_arches (void)
648 {
649   arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
650   scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
651 
652   gdbscm_define_functions (arch_functions, 1);
653 }
654