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