gdb/guile/guile.c

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