1 /* General GDB/Guile code.
2 
3    Copyright (C) 2014-2021 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 "defs.h"
24 #include "breakpoint.h"
25 #include "cli/cli-cmds.h"
26 #include "cli/cli-script.h"
27 #include "cli/cli-utils.h"
28 #include "command.h"
29 #include "gdbcmd.h"
30 #include "top.h"
31 #include "extension-priv.h"
32 #include "utils.h"
33 #include "gdbsupport/version.h"
34 #ifdef HAVE_GUILE
35 #include "guile.h"
36 #include "guile-internal.h"
37 #endif
38 #include <signal.h>
39 #include "gdbsupport/block-signals.h"
40 
41 /* The Guile version we're using.
42    We *could* use the macros in libguile/version.h but that would preclude
43    handling the user switching in a different version with, e.g.,
44    LD_LIBRARY_PATH (using a different version than what gdb was compiled with
45    is not something to be done lightly, but can be useful).  */
46 int gdbscm_guile_major_version;
47 int gdbscm_guile_minor_version;
48 int gdbscm_guile_micro_version;
49 
50 #ifdef HAVE_GUILE
51 /* The guile subdirectory within gdb's data-directory.  */
52 static const char *guile_datadir;
53 #endif
54 
55 /* Declared constants and enum for guile exception printing.  */
56 const char gdbscm_print_excp_none[] = "none";
57 const char gdbscm_print_excp_full[] = "full";
58 const char gdbscm_print_excp_message[] = "message";
59 
60 /* "set guile print-stack" choices.  */
61 static const char *const guile_print_excp_enums[] =
62   {
63     gdbscm_print_excp_none,
64     gdbscm_print_excp_full,
65     gdbscm_print_excp_message,
66     NULL
67   };
68 
69 /* The exception printing variable.  'full' if we want to print the
70    error message and stack, 'none' if we want to print nothing, and
71    'message' if we only want to print the error message.  'message' is
72    the default.  */
73 const char *gdbscm_print_excp = gdbscm_print_excp_message;
74 
75 
76 #ifdef HAVE_GUILE
77 
78 static void gdbscm_initialize (const struct extension_language_defn *);
79 static int gdbscm_initialized (const struct extension_language_defn *);
80 static void gdbscm_eval_from_control_command
81   (const struct extension_language_defn *, struct command_line *);
82 static script_sourcer_func gdbscm_source_script;
83 static void gdbscm_set_backtrace (int enable);
84 
85 int gdb_scheme_initialized;
86 
87 /* Symbol for setting documentation strings.  */
88 SCM gdbscm_documentation_symbol;
89 
90 /* Keywords used by various functions.  */
91 static SCM from_tty_keyword;
92 static SCM to_string_keyword;
93 
94 /* The name of the various modules (without the surrounding parens).  */
95 const char gdbscm_module_name[] = "gdb";
96 const char gdbscm_init_module_name[] = "gdb";
97 
98 /* The name of the bootstrap file.  */
99 static const char boot_scm_filename[] = "boot.scm";
100 
101 /* The interface between gdb proper and loading of python scripts.  */
102 
103 static const struct extension_language_script_ops guile_extension_script_ops =
104 {
105   gdbscm_source_script,
106   gdbscm_source_objfile_script,
107   gdbscm_execute_objfile_script,
108   gdbscm_auto_load_enabled
109 };
110 
111 /* The interface between gdb proper and guile scripting.  */
112 
113 static const struct extension_language_ops guile_extension_ops =
114 {
115   gdbscm_initialize,
116   gdbscm_initialized,
117 
118   gdbscm_eval_from_control_command,
119 
120   NULL, /* gdbscm_start_type_printers, */
121   NULL, /* gdbscm_apply_type_printers, */
122   NULL, /* gdbscm_free_type_printers, */
123 
124   gdbscm_apply_val_pretty_printer,
125 
126   NULL, /* gdbscm_apply_frame_filter, */
127 
128   gdbscm_preserve_values,
129 
130   gdbscm_breakpoint_has_cond,
131   gdbscm_breakpoint_cond_says_stop,
132 
133   NULL, /* gdbscm_check_quit_flag, */
134   NULL, /* gdbscm_set_quit_flag, */
135 };
136 #endif
137 
138 /* The main struct describing GDB's interface to the Guile
139    extension language.  */
140 extern const struct extension_language_defn extension_language_guile =
141 {
142   EXT_LANG_GUILE,
143   "guile",
144   "Guile",
145 
146   ".scm",
147   "-gdb.scm",
148 
149   guile_control,
150 
151 #ifdef HAVE_GUILE
152   &guile_extension_script_ops,
153   &guile_extension_ops
154 #else
155   NULL,
156   NULL
157 #endif
158 };
159 
160 #ifdef HAVE_GUILE
161 /* Implementation of the gdb "guile-repl" command.  */
162 
163 static void
guile_repl_command(const char * arg,int from_tty)164 guile_repl_command (const char *arg, int from_tty)
165 {
166   scoped_restore restore_async = make_scoped_restore (&current_ui->async, 0);
167 
168   arg = skip_spaces (arg);
169 
170   /* This explicitly rejects any arguments for now.
171      "It is easier to relax a restriction than impose one after the fact."
172      We would *like* to be able to pass arguments to the interactive shell
173      but that's not what python-interactive does.  Until there is time to
174      sort it out, we forbid arguments.  */
175 
176   if (arg && *arg)
177     error (_("guile-repl currently does not take any arguments."));
178   else
179     {
180       dont_repeat ();
181       gdbscm_enter_repl ();
182     }
183 }
184 
185 /* Implementation of the gdb "guile" command.
186    Note: Contrary to the Python version this displays the result.
187    Have to see which is better.
188 
189    TODO: Add the result to Guile's history?  */
190 
191 static void
guile_command(const char * arg,int from_tty)192 guile_command (const char *arg, int from_tty)
193 {
194   scoped_restore restore_async = make_scoped_restore (&current_ui->async, 0);
195 
196   arg = skip_spaces (arg);
197 
198   if (arg && *arg)
199     {
200       gdb::unique_xmalloc_ptr<char> msg = gdbscm_safe_eval_string (arg, 1);
201 
202       if (msg != NULL)
203 	error ("%s", msg.get ());
204     }
205   else
206     {
207       counted_command_line l = get_command_line (guile_control, "");
208 
209       execute_control_command_untraced (l.get ());
210     }
211 }
212 
213 /* Given a command_line, return a command string suitable for passing
214    to Guile.  Lines in the string are separated by newlines.  The return
215    value is allocated using xmalloc and the caller is responsible for
216    freeing it.  */
217 
218 static char *
compute_scheme_string(struct command_line * l)219 compute_scheme_string (struct command_line *l)
220 {
221   struct command_line *iter;
222   char *script = NULL;
223   int size = 0;
224   int here;
225 
226   for (iter = l; iter; iter = iter->next)
227     size += strlen (iter->line) + 1;
228 
229   script = (char *) xmalloc (size + 1);
230   here = 0;
231   for (iter = l; iter; iter = iter->next)
232     {
233       int len = strlen (iter->line);
234 
235       strcpy (&script[here], iter->line);
236       here += len;
237       script[here++] = '\n';
238     }
239   script[here] = '\0';
240   return script;
241 }
242 
243 /* Take a command line structure representing a "guile" command, and
244    evaluate its body using the Guile interpreter.
245    This is the extension_language_ops.eval_from_control_command "method".  */
246 
247 static void
gdbscm_eval_from_control_command(const struct extension_language_defn * extlang,struct command_line * cmd)248 gdbscm_eval_from_control_command
249   (const struct extension_language_defn *extlang, struct command_line *cmd)
250 {
251   char *script;
252 
253   if (cmd->body_list_1 != nullptr)
254     error (_("Invalid \"guile\" block structure."));
255 
256   script = compute_scheme_string (cmd->body_list_0.get ());
257   gdb::unique_xmalloc_ptr<char> msg = gdbscm_safe_eval_string (script, 0);
258   xfree (script);
259   if (msg != NULL)
260     error ("%s", msg.get ());
261 }
262 
263 /* Read a file as Scheme code.
264    This is the extension_language_script_ops.script_sourcer "method".
265    FILE is the file to run.  FILENAME is name of the file FILE.
266    This does not throw any errors.  If an exception occurs an error message
267    is printed.  */
268 
269 static void
gdbscm_source_script(const struct extension_language_defn * extlang,FILE * file,const char * filename)270 gdbscm_source_script (const struct extension_language_defn *extlang,
271 		      FILE *file, const char *filename)
272 {
273   gdb::unique_xmalloc_ptr<char> msg = gdbscm_safe_source_script (filename);
274 
275   if (msg != NULL)
276     fprintf_filtered (gdb_stderr, "%s\n", msg.get ());
277 }
278 
279 /* (execute string [#:from-tty boolean] [#:to-string boolean])
280    A Scheme function which evaluates a string using the gdb CLI.  */
281 
282 static SCM
gdbscm_execute_gdb_command(SCM command_scm,SCM rest)283 gdbscm_execute_gdb_command (SCM command_scm, SCM rest)
284 {
285   int from_tty_arg_pos = -1, to_string_arg_pos = -1;
286   int from_tty = 0, to_string = 0;
287   const SCM keywords[] = { from_tty_keyword, to_string_keyword, SCM_BOOL_F };
288   char *command;
289 
290   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#tt",
291 			      command_scm, &command, rest,
292 			      &from_tty_arg_pos, &from_tty,
293 			      &to_string_arg_pos, &to_string);
294 
295   return gdbscm_wrap ([=]
296     {
297       gdb::unique_xmalloc_ptr<char> command_holder (command);
298       std::string to_string_res;
299 
300       scoped_restore restore_async = make_scoped_restore (&current_ui->async,
301 							  0);
302 
303       scoped_restore preventer = prevent_dont_repeat ();
304       if (to_string)
305 	to_string_res = execute_command_to_string (command, from_tty, false);
306       else
307 	execute_command (command, from_tty);
308 
309       /* Do any commands attached to breakpoint we stopped at.  */
310       bpstat_do_actions ();
311 
312       if (to_string)
313 	return gdbscm_scm_from_c_string (to_string_res.c_str ());
314       return SCM_UNSPECIFIED;
315     });
316 }
317 
318 /* (data-directory) -> string */
319 
320 static SCM
gdbscm_data_directory(void)321 gdbscm_data_directory (void)
322 {
323   return gdbscm_scm_from_c_string (gdb_datadir.c_str ());
324 }
325 
326 /* (guile-data-directory) -> string */
327 
328 static SCM
gdbscm_guile_data_directory(void)329 gdbscm_guile_data_directory (void)
330 {
331   return gdbscm_scm_from_c_string (guile_datadir);
332 }
333 
334 /* (gdb-version) -> string */
335 
336 static SCM
gdbscm_gdb_version(void)337 gdbscm_gdb_version (void)
338 {
339   return gdbscm_scm_from_c_string (version);
340 }
341 
342 /* (host-config) -> string */
343 
344 static SCM
gdbscm_host_config(void)345 gdbscm_host_config (void)
346 {
347   return gdbscm_scm_from_c_string (host_name);
348 }
349 
350 /* (target-config) -> string */
351 
352 static SCM
gdbscm_target_config(void)353 gdbscm_target_config (void)
354 {
355   return gdbscm_scm_from_c_string (target_name);
356 }
357 
358 #else /* ! HAVE_GUILE */
359 
360 /* Dummy implementation of the gdb "guile-repl" and "guile"
361    commands. */
362 
363 static void
guile_repl_command(const char * arg,int from_tty)364 guile_repl_command (const char *arg, int from_tty)
365 {
366   arg = skip_spaces (arg);
367   if (arg && *arg)
368     error (_("guile-repl currently does not take any arguments."));
369   error (_("Guile scripting is not supported in this copy of GDB."));
370 }
371 
372 static void
guile_command(const char * arg,int from_tty)373 guile_command (const char *arg, int from_tty)
374 {
375   arg = skip_spaces (arg);
376   if (arg && *arg)
377     error (_("Guile scripting is not supported in this copy of GDB."));
378   else
379     {
380       /* Even if Guile isn't enabled, we still have to slurp the
381 	 command list to the corresponding "end".  */
382       counted_command_line l = get_command_line (guile_control, "");
383 
384       execute_control_command_untraced (l.get ());
385     }
386 }
387 
388 #endif /* ! HAVE_GUILE */
389 
390 /* Lists for 'set,show,info guile' commands.  */
391 
392 static struct cmd_list_element *set_guile_list;
393 static struct cmd_list_element *show_guile_list;
394 static struct cmd_list_element *info_guile_list;
395 
396 
397 /* Initialization.  */
398 
399 #ifdef HAVE_GUILE
400 
401 static const scheme_function misc_guile_functions[] =
402 {
403   { "execute", 1, 0, 1, as_a_scm_t_subr (gdbscm_execute_gdb_command),
404   "\
405 Execute the given GDB command.\n\
406 \n\
407   Arguments: string [#:to-string boolean] [#:from-tty boolean]\n\
408     If #:from-tty is true then the command executes as if entered\n\
409     from the keyboard.  The default is false (#f).\n\
410     If #:to-string is true then the result is returned as a string.\n\
411     Otherwise output is sent to the current output port,\n\
412     which is the default.\n\
413   Returns: The result of the command if #:to-string is true.\n\
414     Otherwise returns unspecified." },
415 
416   { "data-directory", 0, 0, 0, as_a_scm_t_subr (gdbscm_data_directory),
417     "\
418 Return the name of GDB's data directory." },
419 
420   { "guile-data-directory", 0, 0, 0,
421     as_a_scm_t_subr (gdbscm_guile_data_directory),
422     "\
423 Return the name of the Guile directory within GDB's data directory." },
424 
425   { "gdb-version", 0, 0, 0, as_a_scm_t_subr (gdbscm_gdb_version),
426     "\
427 Return GDB's version string." },
428 
429   { "host-config", 0, 0, 0, as_a_scm_t_subr (gdbscm_host_config),
430     "\
431 Return the name of the host configuration." },
432 
433   { "target-config", 0, 0, 0, as_a_scm_t_subr (gdbscm_target_config),
434     "\
435 Return the name of the target configuration." },
436 
437   END_FUNCTIONS
438 };
439 
440 /* Load BOOT_SCM_FILE, the first Scheme file that gets loaded.  */
441 
442 static SCM
boot_guile_support(void * boot_scm_file)443 boot_guile_support (void *boot_scm_file)
444 {
445   /* Load boot.scm without compiling it (there's no need to compile it).
446      The other files should have been compiled already, and boot.scm is
447      expected to adjust '%load-compiled-path' accordingly.  If they haven't
448      been compiled, Guile will auto-compile them. The important thing to keep
449      in mind is that there's a >= 100x speed difference between compiled and
450      non-compiled files.  */
451   return scm_c_primitive_load ((const char *) boot_scm_file);
452 }
453 
454 /* Return non-zero if ARGS has the "standard" format for throw args.
455    The standard format is:
456    (function format-string (format-string-args-list) ...).
457    FUNCTION is #f if no function was recorded.  */
458 
459 static int
standard_throw_args_p(SCM args)460 standard_throw_args_p (SCM args)
461 {
462   if (gdbscm_is_true (scm_list_p (args))
463       && scm_ilength (args) >= 3)
464     {
465       /* The function in which the error occurred.  */
466       SCM arg0 = scm_list_ref (args, scm_from_int (0));
467       /* The format string.  */
468       SCM arg1 = scm_list_ref (args, scm_from_int (1));
469       /* The arguments of the format string.  */
470       SCM arg2 = scm_list_ref (args, scm_from_int (2));
471 
472       if ((scm_is_string (arg0) || gdbscm_is_false (arg0))
473 	  && scm_is_string (arg1)
474 	  && gdbscm_is_true (scm_list_p (arg2)))
475 	return 1;
476     }
477 
478   return 0;
479 }
480 
481 /* Print the error recorded in a "standard" throw args.  */
482 
483 static void
print_standard_throw_error(SCM args)484 print_standard_throw_error (SCM args)
485 {
486   /* The function in which the error occurred.  */
487   SCM arg0 = scm_list_ref (args, scm_from_int (0));
488   /* The format string.  */
489   SCM arg1 = scm_list_ref (args, scm_from_int (1));
490   /* The arguments of the format string.  */
491   SCM arg2 = scm_list_ref (args, scm_from_int (2));
492 
493   /* ARG0 is #f if no function was recorded.  */
494   if (gdbscm_is_true (arg0))
495     {
496       scm_simple_format (scm_current_error_port (),
497 			 scm_from_latin1_string (_("Error in function ~s:~%")),
498 			 scm_list_1 (arg0));
499     }
500   scm_simple_format (scm_current_error_port (), arg1, arg2);
501 }
502 
503 /* Print the error message recorded in KEY, ARGS, the arguments to throw.
504    Normally we let Scheme print the error message.
505    This function is used when Scheme initialization fails.
506    We can still use the Scheme C API though.  */
507 
508 static void
print_throw_error(SCM key,SCM args)509 print_throw_error (SCM key, SCM args)
510 {
511   /* IWBN to call gdbscm_print_exception_with_stack here, but Guile didn't
512      boot successfully so play it safe and avoid it.  The "format string" and
513      its args are embedded in ARGS, but the content of ARGS depends on KEY.
514      Make sure ARGS has the expected canonical content before trying to use
515      it.  */
516   if (standard_throw_args_p (args))
517     print_standard_throw_error (args);
518   else
519     {
520       scm_simple_format (scm_current_error_port (),
521 			 scm_from_latin1_string (_("Throw to key `~a' with args `~s'.~%")),
522 			 scm_list_2 (key, args));
523     }
524 }
525 
526 /* Handle an exception thrown while loading BOOT_SCM_FILE.  */
527 
528 static SCM
handle_boot_error(void * boot_scm_file,SCM key,SCM args)529 handle_boot_error (void *boot_scm_file, SCM key, SCM args)
530 {
531   fprintf_unfiltered (gdb_stderr, ("Exception caught while booting Guile.\n"));
532 
533   print_throw_error (key, args);
534 
535   fprintf_unfiltered (gdb_stderr, "\n");
536   warning (_("Could not complete Guile gdb module initialization from:\n"
537 	     "%s.\n"
538 	     "Limited Guile support is available.\n"
539 	     "Suggest passing --data-directory=/path/to/gdb/data-directory."),
540 	   (const char *) boot_scm_file);
541 
542   return SCM_UNSPECIFIED;
543 }
544 
545 /* Load gdb/boot.scm, the Scheme side of GDB/Guile support.
546    Note: This function assumes it's called within the gdb module.  */
547 
548 static void
initialize_scheme_side(void)549 initialize_scheme_side (void)
550 {
551   char *boot_scm_path;
552 
553   guile_datadir = concat (gdb_datadir.c_str (), SLASH_STRING, "guile",
554 			  (char *) NULL);
555   boot_scm_path = concat (guile_datadir, SLASH_STRING, "gdb",
556 			  SLASH_STRING, boot_scm_filename, (char *) NULL);
557 
558   scm_c_catch (SCM_BOOL_T, boot_guile_support, boot_scm_path,
559 	       handle_boot_error, boot_scm_path, NULL, NULL);
560 
561   xfree (boot_scm_path);
562 }
563 
564 /* Install the gdb scheme module.
565    The result is a boolean indicating success.
566    If initializing the gdb module fails an error message is printed.
567    Note: This function runs in the context of the gdb module.  */
568 
569 static void
initialize_gdb_module(void * data)570 initialize_gdb_module (void *data)
571 {
572   /* Computing these is a pain, so only do it once.
573      Also, do it here and save the result so that obtaining the values
574      is thread-safe.  */
575   gdbscm_guile_major_version = gdbscm_scm_string_to_int (scm_major_version ());
576   gdbscm_guile_minor_version = gdbscm_scm_string_to_int (scm_minor_version ());
577   gdbscm_guile_micro_version = gdbscm_scm_string_to_int (scm_micro_version ());
578 
579   /* The documentation symbol needs to be defined before any calls to
580      gdbscm_define_{variables,functions}.  */
581   gdbscm_documentation_symbol = scm_from_latin1_symbol ("documentation");
582 
583   /* The smob and exception support must be initialized early.  */
584   gdbscm_initialize_smobs ();
585   gdbscm_initialize_exceptions ();
586 
587   /* The rest are initialized in alphabetical order.  */
588   gdbscm_initialize_arches ();
589   gdbscm_initialize_auto_load ();
590   gdbscm_initialize_blocks ();
591   gdbscm_initialize_breakpoints ();
592   gdbscm_initialize_commands ();
593   gdbscm_initialize_disasm ();
594   gdbscm_initialize_frames ();
595   gdbscm_initialize_iterators ();
596   gdbscm_initialize_lazy_strings ();
597   gdbscm_initialize_math ();
598   gdbscm_initialize_objfiles ();
599   gdbscm_initialize_parameters ();
600   gdbscm_initialize_ports ();
601   gdbscm_initialize_pretty_printers ();
602   gdbscm_initialize_pspaces ();
603   gdbscm_initialize_strings ();
604   gdbscm_initialize_symbols ();
605   gdbscm_initialize_symtabs ();
606   gdbscm_initialize_types ();
607   gdbscm_initialize_values ();
608 
609   gdbscm_define_functions (misc_guile_functions, 1);
610 
611   from_tty_keyword = scm_from_latin1_keyword ("from-tty");
612   to_string_keyword = scm_from_latin1_keyword ("to-string");
613 
614   initialize_scheme_side ();
615 
616   gdb_scheme_initialized = 1;
617 }
618 
619 /* Utility to call scm_c_define_module+initialize_gdb_module from
620    within scm_with_guile.  */
621 
622 static void *
call_initialize_gdb_module(void * data)623 call_initialize_gdb_module (void *data)
624 {
625   /* Most of the initialization is done by initialize_gdb_module.
626      It is called via scm_c_define_module so that the initialization is
627      performed within the desired module.  */
628   scm_c_define_module (gdbscm_module_name, initialize_gdb_module, NULL);
629 
630 #if HAVE_GUILE_MANUAL_FINALIZATION
631   scm_run_finalizers ();
632 #endif
633 
634   return NULL;
635 }
636 
637 /* A callback to initialize Guile after gdb has finished all its
638    initialization.  This is the extension_language_ops.initialize "method".  */
639 
640 static void
gdbscm_initialize(const struct extension_language_defn * extlang)641 gdbscm_initialize (const struct extension_language_defn *extlang)
642 {
643 #if HAVE_GUILE
644   /* The Python support puts the C side in module "_gdb", leaving the
645      Python side to define module "gdb" which imports "_gdb".  There is
646      evidently no similar convention in Guile so we skip this.  */
647 
648 #if HAVE_GUILE_MANUAL_FINALIZATION
649   /* Our SMOB free functions are not thread-safe, as GDB itself is not
650      intended to be thread-safe.  Disable automatic finalization so that
651      finalizers aren't run in other threads.  */
652   scm_set_automatic_finalization_enabled (0);
653 #endif
654 
655   /* Before we initialize Guile, block signals needed by gdb (especially
656      SIGCHLD).  This is done so that all threads created during Guile
657      initialization have SIGCHLD blocked.  PR 17247.  Really libgc and
658      Guile should do this, but we need to work with libgc 7.4.x.  */
659   {
660     gdb::block_signals blocker;
661 
662     /* There are libguile versions (f.i. v3.0.5) that by default call
663        mp_get_memory_functions during initialization to install custom
664        libgmp memory functions.  This is considered a bug and should be
665        fixed starting v3.0.6.
666        Before gdb commit 880ae75a2b7 "gdb delay guile initialization until
667        gdbscm_finish_initialization", that bug had no effect for gdb,
668        because gdb subsequently called mp_get_memory_functions to install
669        its own custom functions in _initialize_gmp_utils.  However, since
670        aforementioned gdb commit the initialization order is reversed,
671        allowing libguile to install a custom malloc that is incompatible
672        with the custom free as used in gmp-utils.c, resulting in a
673        "double free or corruption (out)" error.
674        Work around the libguile bug by disabling the installation of the
675        libgmp memory functions by guile initialization.  */
676     scm_install_gmp_memory_functions = 0;
677 
678     /* scm_with_guile is the most portable way to initialize Guile.  Plus
679        we need to initialize the Guile support while in Guile mode (e.g.,
680        called from within a call to scm_with_guile).  */
681     scm_with_guile (call_initialize_gdb_module, NULL);
682   }
683 
684   /* Set Guile's backtrace to match the "set guile print-stack" default.
685      [N.B. The two settings are still separate.]  But only do this after
686      we've initialized Guile, it's nice to see a backtrace if there's an
687      error during initialization.  OTOH, if the error is that gdb/init.scm
688      wasn't found because gdb is being run from the build tree, the
689      backtrace is more noise than signal.  Sigh.  */
690   gdbscm_set_backtrace (0);
691 #endif
692 
693   /* Restore the environment to the user interaction one.  */
694   scm_set_current_module (scm_interaction_environment ());
695 }
696 
697 /* The extension_language_ops.initialized "method".  */
698 
699 static int
gdbscm_initialized(const struct extension_language_defn * extlang)700 gdbscm_initialized (const struct extension_language_defn *extlang)
701 {
702   return gdb_scheme_initialized;
703 }
704 
705 /* Enable or disable Guile backtraces.  */
706 
707 static void
gdbscm_set_backtrace(int enable)708 gdbscm_set_backtrace (int enable)
709 {
710   static const char disable_bt[] = "(debug-disable 'backtrace)";
711   static const char enable_bt[] = "(debug-enable 'backtrace)";
712 
713   if (enable)
714     gdbscm_safe_eval_string (enable_bt, 0);
715   else
716     gdbscm_safe_eval_string (disable_bt, 0);
717 }
718 
719 #endif /* HAVE_GUILE */
720 
721 /* See guile.h.  */
722 cmd_list_element *guile_cmd_element = nullptr;
723 
724 /* Install the various gdb commands used by Guile.  */
725 
726 static void
install_gdb_commands(void)727 install_gdb_commands (void)
728 {
729   cmd_list_element *guile_repl_cmd
730     = add_com ("guile-repl", class_obscure, guile_repl_command,
731 #ifdef HAVE_GUILE
732 	   _("\
733 Start an interactive Guile prompt.\n\
734 \n\
735 To return to GDB, type the EOF character (e.g., Ctrl-D on an empty\n\
736 prompt) or ,quit.")
737 #else /* HAVE_GUILE */
738 	   _("\
739 Start a Guile interactive prompt.\n\
740 \n\
741 Guile scripting is not supported in this copy of GDB.\n\
742 This command is only a placeholder.")
743 #endif /* HAVE_GUILE */
744 	   );
745   add_com_alias ("gr", guile_repl_cmd, class_obscure, 1);
746 
747   /* Since "help guile" is easy to type, and intuitive, we add general help
748      in using GDB+Guile to this command.  */
749   guile_cmd_element = add_com ("guile", class_obscure, guile_command,
750 #ifdef HAVE_GUILE
751 	   _("\
752 Evaluate one or more Guile expressions.\n\
753 \n\
754 The expression(s) can be given as an argument, for instance:\n\
755 \n\
756     guile (display 23)\n\
757 \n\
758 The result of evaluating the last expression is printed.\n\
759 \n\
760 If no argument is given, the following lines are read and passed\n\
761 to Guile for evaluation.  Type a line containing \"end\" to indicate\n\
762 the end of the set of expressions.\n\
763 \n\
764 The Guile GDB module must first be imported before it can be used.\n\
765 Do this with:\n\
766 (gdb) guile (use-modules (gdb))\n\
767 or if you want to import the (gdb) module with a prefix, use:\n\
768 (gdb) guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))\n\
769 \n\
770 The Guile interactive session, started with the \"guile-repl\"\n\
771 command, provides extensive help and apropos capabilities.\n\
772 Type \",help\" once in a Guile interactive session.")
773 #else /* HAVE_GUILE */
774 	   _("\
775 Evaluate a Guile expression.\n\
776 \n\
777 Guile scripting is not supported in this copy of GDB.\n\
778 This command is only a placeholder.")
779 #endif /* HAVE_GUILE */
780 	   );
781   add_com_alias ("gu", guile_cmd_element, class_obscure, 1);
782 
783   cmd_list_element *set_guile_cmd
784     = add_basic_prefix_cmd ("guile", class_obscure,
785 			    _("Prefix command for Guile preference settings."),
786 			    &set_guile_list, 0, &setlist);
787   add_alias_cmd ("gu", set_guile_cmd, class_obscure, 1, &setlist);
788 
789   cmd_list_element *show_guile_cmd
790     = add_show_prefix_cmd ("guile", class_obscure,
791 			   _("Prefix command for Guile preference settings."),
792 			   &show_guile_list, 0, &showlist);
793   add_alias_cmd ("gu", show_guile_cmd, class_obscure, 1, &showlist);
794 
795   cmd_list_element *info_guile_cmd
796     = add_basic_prefix_cmd ("guile", class_obscure,
797 			    _("Prefix command for Guile info displays."),
798 			    &info_guile_list, 0, &infolist);
799   add_info_alias ("gu", info_guile_cmd, 1);
800 
801   /* The name "print-stack" is carried over from Python.
802      A better name is "print-exception".  */
803   add_setshow_enum_cmd ("print-stack", no_class, guile_print_excp_enums,
804 			&gdbscm_print_excp, _("\
805 Set mode for Guile exception printing on error."), _("\
806 Show the mode of Guile exception printing on error."), _("\
807 none  == no stack or message will be printed.\n\
808 full == a message and a stack will be printed.\n\
809 message == an error message without a stack will be printed."),
810 			NULL, NULL,
811 			&set_guile_list, &show_guile_list);
812 }
813 
814 void _initialize_guile ();
815 void
_initialize_guile()816 _initialize_guile ()
817 {
818   install_gdb_commands ();
819 }
820