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