gdb/guile/scm-cmd.c

   1 /* GDB commands implemented in Scheme.
   2
   3    Copyright (C) 2008-2019 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 <ctype.h>
  25 #include "charset.h"
  26 #include "gdbcmd.h"
  27 #include "cli/cli-decode.h"
  28 #include "completer.h"
  29 #include "guile-internal.h"
  30
  31 /* The <gdb:command> smob.
  32
  33    Note: Commands are added to gdb using a two step process:
  34    1) Call make-command to create a <gdb:command> object.
  35    2) Call register-command! to add the command to gdb.
  36    It is done this way so that the constructor, make-command, doesn't have
  37    any side-effects.  This means that the smob needs to store everything
  38    that was passed to make-command.  */
  39
  40 typedef struct _command_smob
  41 {
  42   /* This always appears first.  */
  43   gdb_smob base;
  44
  45   /* The name of the command, as passed to make-command.  */
  46   char *name;
  47
  48   /* The last word of the command.
  49      This is needed because add_cmd requires us to allocate space
  50      for it. :-(  */
  51   char *cmd_name;
  52
  53   /* Non-zero if this is a prefix command.  */
  54   int is_prefix;
  55
  56   /* One of the COMMAND_* constants.  */
  57   enum command_class cmd_class;
  58
  59   /* The documentation for the command.  */
  60   char *doc;
  61
  62   /* The corresponding gdb command object.
  63      This is NULL if the command has not been registered yet, or
  64      is no longer registered.  */
  65   struct cmd_list_element *command;
  66
  67   /* A prefix command requires storage for a list of its sub-commands.
  68      A pointer to this is passed to add_prefix_command, and to add_cmd
  69      for sub-commands of that prefix.
  70      This is NULL if the command has not been registered yet, or
  71      is no longer registered.  If this command is not a prefix
  72      command, then this field is unused.  */
  73   struct cmd_list_element *sub_list;
  74
  75   /* The procedure to call to invoke the command.
  76      (lambda (self arg from-tty) ...).
  77      Its result is unspecified.  */
  78   SCM invoke;
  79
  80   /* Either #f, one of the COMPLETE_* constants, or a procedure to call to
  81      perform command completion.  Called as (lambda (self text word) ...).  */
  82   SCM complete;
  83
  84   /* The <gdb:command> object we are contained in, needed to protect/unprotect
  85      the object since a reference to it comes from non-gc-managed space
  86      (the command context pointer).  */
  87   SCM containing_scm;
  88 } command_smob;
  89
  90 static const char command_smob_name[] = "gdb:command";
  91
  92 /* The tag Guile knows the objfile smob by.  */
  93 static scm_t_bits command_smob_tag;
  94
  95 /* Keywords used by make-command.  */
  96 static SCM invoke_keyword;
  97 static SCM command_class_keyword;
  98 static SCM completer_class_keyword;
  99 static SCM prefix_p_keyword;
 100 static SCM doc_keyword;
 101
 102 /* Struct representing built-in completion types.  */
 103 struct cmdscm_completer
 104 {
 105   /* Scheme symbol name.  */
 106   const char *name;
 107   /* Completion function.  */
 108   completer_ftype *completer;
 109 };
 110
 111 static const struct cmdscm_completer cmdscm_completers[] =
 112 {
 113   { "COMPLETE_NONE", noop_completer },
 114   { "COMPLETE_FILENAME", filename_completer },
 115   { "COMPLETE_LOCATION", location_completer },
 116   { "COMPLETE_COMMAND", command_completer },
 117   { "COMPLETE_SYMBOL", symbol_completer },
 118   { "COMPLETE_EXPRESSION", expression_completer },
 119 };
 120
 121 #define N_COMPLETERS (sizeof (cmdscm_completers) \
 122                       / sizeof (cmdscm_completers[0]))
 123
 124 static int cmdscm_is_valid (command_smob *);
 125 \f
 126 /* Administrivia for command smobs.  */
 127
 128 /* The smob "print" function for <gdb:command>.  */
 129
 130 static int
 131 cmdscm_print_command_smob (SCM self, SCM port, scm_print_state *pstate)
 132 {
 133   command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (self);
 134
 135   gdbscm_printf (port, "#<%s", command_smob_name);
 136
 137   gdbscm_printf (port, " %s",
 138                  c_smob->name != NULL ? c_smob->name : "{unnamed}");
 139
 140   if (! cmdscm_is_valid (c_smob))
 141     scm_puts (" {invalid}", port);
 142
 143   scm_puts (">", port);
 144
 145   scm_remember_upto_here_1 (self);
 146
 147   /* Non-zero means success.  */
 148   return 1;
 149 }
 150
 151 /* Low level routine to create a <gdb:command> object.
 152    It's empty in the sense that a command still needs to be associated
 153    with it.  */
 154
 155 static SCM
 156 cmdscm_make_command_smob (void)
 157 {
 158   command_smob *c_smob = (command_smob *)
 159     scm_gc_malloc (sizeof (command_smob), command_smob_name);
 160   SCM c_scm;
 161
 162   memset (c_smob, 0, sizeof (*c_smob));
 163   c_smob->cmd_class = no_class;
 164   c_smob->invoke = SCM_BOOL_F;
 165   c_smob->complete = SCM_BOOL_F;
 166   c_scm = scm_new_smob (command_smob_tag, (scm_t_bits) c_smob);
 167   c_smob->containing_scm = c_scm;
 168   gdbscm_init_gsmob (&c_smob->base);
 169
 170   return c_scm;
 171 }
 172
 173 /* Clear the COMMAND pointer in C_SMOB and unprotect the object from GC.  */
 174
 175 static void
 176 cmdscm_release_command (command_smob *c_smob)
 177 {
 178   c_smob->command = NULL;
 179   scm_gc_unprotect_object (c_smob->containing_scm);
 180 }
 181
 182 /* Return non-zero if SCM is a command smob.  */
 183
 184 static int
 185 cmdscm_is_command (SCM scm)
 186 {
 187   return SCM_SMOB_PREDICATE (command_smob_tag, scm);
 188 }
 189
 190 /* (command? scm) -> boolean */
 191
 192 static SCM
 193 gdbscm_command_p (SCM scm)
 194 {
 195   return scm_from_bool (cmdscm_is_command (scm));
 196 }
 197
 198 /* Returns the <gdb:command> object in SELF.
 199    Throws an exception if SELF is not a <gdb:command> object.  */
 200
 201 static SCM
 202 cmdscm_get_command_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 203 {
 204   SCM_ASSERT_TYPE (cmdscm_is_command (self), self, arg_pos, func_name,
 205                    command_smob_name);
 206
 207   return self;
 208 }
 209
 210 /* Returns a pointer to the command smob of SELF.
 211    Throws an exception if SELF is not a <gdb:command> object.  */
 212
 213 static command_smob *
 214 cmdscm_get_command_smob_arg_unsafe (SCM self, int arg_pos,
 215                                     const char *func_name)
 216 {
 217   SCM c_scm = cmdscm_get_command_arg_unsafe (self, arg_pos, func_name);
 218   command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 219
 220   return c_smob;
 221 }
 222
 223 /* Return non-zero if command C_SMOB is valid.  */
 224
 225 static int
 226 cmdscm_is_valid (command_smob *c_smob)
 227 {
 228   return c_smob->command != NULL;
 229 }
 230
 231 /* Returns a pointer to the command smob of SELF.
 232    Throws an exception if SELF is not a valid <gdb:command> object.  */
 233
 234 static command_smob *
 235 cmdscm_get_valid_command_smob_arg_unsafe (SCM self, int arg_pos,
 236                                           const char *func_name)
 237 {
 238   command_smob *c_smob
 239     = cmdscm_get_command_smob_arg_unsafe (self, arg_pos, func_name);
 240
 241   if (!cmdscm_is_valid (c_smob))
 242     {
 243       gdbscm_invalid_object_error (func_name, arg_pos, self,
 244                                    _("<gdb:command>"));
 245     }
 246
 247   return c_smob;
 248 }
 249 \f
 250 /* Scheme functions for GDB commands.  */
 251
 252 /* (command-valid? <gdb:command>) -> boolean
 253    Returns #t if SELF is still valid.  */
 254
 255 static SCM
 256 gdbscm_command_valid_p (SCM self)
 257 {
 258   command_smob *c_smob
 259     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 260
 261   return scm_from_bool (cmdscm_is_valid (c_smob));
 262 }
 263
 264 /* (dont-repeat cmd) -> unspecified
 265    Scheme function which wraps dont_repeat.  */
 266
 267 static SCM
 268 gdbscm_dont_repeat (SCM self)
 269 {
 270   /* We currently don't need anything from SELF, but still verify it.
 271      Call for side effects.  */
 272   cmdscm_get_valid_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 273
 274   dont_repeat ();
 275
 276   return SCM_UNSPECIFIED;
 277 }
 278 \f
 279 /* The make-command function.  */
 280
 281 /* Called if the gdb cmd_list_element is destroyed.  */
 282
 283 static void
 284 cmdscm_destroyer (struct cmd_list_element *self, void *context)
 285 {
 286   command_smob *c_smob = (command_smob *) context;
 287
 288   cmdscm_release_command (c_smob);
 289 }
 290
 291 /* Called by gdb to invoke the command.  */
 292
 293 static void
 294 cmdscm_function (struct cmd_list_element *command,
 295                  const char *args, int from_tty)
 296 {
 297   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 298   SCM arg_scm, tty_scm, result;
 299
 300   gdb_assert (c_smob != NULL);
 301
 302   if (args == NULL)
 303     args = "";
 304   arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
 305   if (gdbscm_is_exception (arg_scm))
 306     error (_("Could not convert arguments to Scheme string."));
 307
 308   tty_scm = scm_from_bool (from_tty);
 309
 310   result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
 311                                arg_scm, tty_scm, gdbscm_user_error_p);
 312
 313   if (gdbscm_is_exception (result))
 314     {
 315       /* Don't print the stack if this was an error signalled by the command
 316          itself.  */
 317       if (gdbscm_user_error_p (gdbscm_exception_key (result)))
 318         {
 319           gdb::unique_xmalloc_ptr<char> msg
 320             = gdbscm_exception_message_to_string (result);
 321
 322           error ("%s", msg.get ());
 323         }
 324       else
 325         {
 326           gdbscm_print_gdb_exception (SCM_BOOL_F, result);
 327           error (_("Error occurred in Scheme-implemented GDB command."));
 328         }
 329     }
 330 }
 331
 332 /* Subroutine of cmdscm_completer to simplify it.
 333    Print an error message indicating that COMPLETION is a bad completion
 334    result.  */
 335
 336 static void
 337 cmdscm_bad_completion_result (const char *msg, SCM completion)
 338 {
 339   SCM port = scm_current_error_port ();
 340
 341   scm_puts (msg, port);
 342   scm_display (completion, port);
 343   scm_newline (port);
 344 }
 345
 346 /* Subroutine of cmdscm_completer to simplify it.
 347    Validate COMPLETION and add to RESULT.
 348    If an error occurs print an error message.
 349    The result is a boolean indicating success.  */
 350
 351 static int
 352 cmdscm_add_completion (SCM completion, completion_tracker &tracker)
 353 {
 354   SCM except_scm;
 355
 356   if (!scm_is_string (completion))
 357     {
 358       /* Inform the user, but otherwise ignore the entire result.  */
 359       cmdscm_bad_completion_result (_("Bad text from completer: "),
 360                                     completion);
 361       return 0;
 362     }
 363
 364   gdb::unique_xmalloc_ptr<char> item
 365     = gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
 366                             &except_scm);
 367   if (item == NULL)
 368     {
 369       /* Inform the user, but otherwise ignore the entire result.  */
 370       gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
 371       return 0;
 372     }
 373
 374   tracker.add_completion (std::move (item));
 375
 376   return 1;
 377 }
 378
 379 /* Called by gdb for command completion.  */
 380
 381 static void
 382 cmdscm_completer (struct cmd_list_element *command,
 383                   completion_tracker &tracker,
 384                   const char *text, const char *word)
 385 {
 386   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 387   SCM completer_result_scm;
 388   SCM text_scm, word_scm;
 389
 390   gdb_assert (c_smob != NULL);
 391   gdb_assert (gdbscm_is_procedure (c_smob->complete));
 392
 393   text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
 394                                      1);
 395   if (gdbscm_is_exception (text_scm))
 396     error (_("Could not convert \"text\" argument to Scheme string."));
 397   word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
 398                                      1);
 399   if (gdbscm_is_exception (word_scm))
 400     error (_("Could not convert \"word\" argument to Scheme string."));
 401
 402   completer_result_scm
 403     = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
 404                           text_scm, word_scm, NULL);
 405
 406   if (gdbscm_is_exception (completer_result_scm))
 407     {
 408       /* Inform the user, but otherwise ignore.  */
 409       gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 410       return;
 411     }
 412
 413   if (gdbscm_is_true (scm_list_p (completer_result_scm)))
 414     {
 415       SCM list = completer_result_scm;
 416
 417       while (!scm_is_eq (list, SCM_EOL))
 418         {
 419           SCM next = scm_car (list);
 420
 421           if (!cmdscm_add_completion (next, tracker))
 422             break;
 423
 424           list = scm_cdr (list);
 425         }
 426     }
 427   else if (itscm_is_iterator (completer_result_scm))
 428     {
 429       SCM iter = completer_result_scm;
 430       SCM next = itscm_safe_call_next_x (iter, NULL);
 431
 432       while (gdbscm_is_true (next))
 433         {
 434           if (gdbscm_is_exception (next))
 435             {
 436               /* Inform the user.  */
 437               gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 438               break;
 439             }
 440
 441           if (cmdscm_add_completion (next, tracker))
 442             break;
 443
 444           next = itscm_safe_call_next_x (iter, NULL);
 445         }
 446     }
 447   else
 448     {
 449       /* Inform the user, but otherwise ignore.  */
 450       cmdscm_bad_completion_result (_("Bad completer result: "),
 451                                     completer_result_scm);
 452     }
 453 }
 454
 455 /* Helper for gdbscm_make_command which locates the command list to use and
 456    pulls out the command name.
 457
 458    NAME is the command name list.  The final word in the list is the
 459    name of the new command.  All earlier words must be existing prefix
 460    commands.
 461
 462    *BASE_LIST is set to the final prefix command's list of
 463    *sub-commands.
 464
 465    START_LIST is the list in which the search starts.
 466
 467    This function returns the xmalloc()d name of the new command.
 468    On error a Scheme exception is thrown.  */
 469
 470 char *
 471 gdbscm_parse_command_name (const char *name,
 472                            const char *func_name, int arg_pos,
 473                            struct cmd_list_element ***base_list,
 474                            struct cmd_list_element **start_list)
 475 {
 476   struct cmd_list_element *elt;
 477   int len = strlen (name);
 478   int i, lastchar;
 479   char *prefix_text;
 480   const char *prefix_text2;
 481   char *result, *msg;
 482
 483   /* Skip trailing whitespace.  */
 484   for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 485     ;
 486   if (i < 0)
 487     {
 488       gdbscm_out_of_range_error (func_name, arg_pos,
 489                                  gdbscm_scm_from_c_string (name),
 490                                  _("no command name found"));
 491     }
 492   lastchar = i;
 493
 494   /* Find first character of the final word.  */
 495   for (; i > 0 && (isalnum (name[i - 1])
 496                    || name[i - 1] == '-'
 497                    || name[i - 1] == '_');
 498        --i)
 499     ;
 500   result = (char *) xmalloc (lastchar - i + 2);
 501   memcpy (result, &name[i], lastchar - i + 1);
 502   result[lastchar - i + 1] = '\0';
 503
 504   /* Skip whitespace again.  */
 505   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 506     ;
 507   if (i < 0)
 508     {
 509       *base_list = start_list;
 510       return result;
 511     }
 512
 513   prefix_text = (char *) xmalloc (i + 2);
 514   memcpy (prefix_text, name, i + 1);
 515   prefix_text[i + 1] = '\0';
 516
 517   prefix_text2 = prefix_text;
 518   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
 519   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
 520     {
 521       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
 522       xfree (prefix_text);
 523       xfree (result);
 524       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 525       gdbscm_dynwind_xfree (msg);
 526       gdbscm_out_of_range_error (func_name, arg_pos,
 527                                  gdbscm_scm_from_c_string (name), msg);
 528     }
 529
 530   if (elt->prefixlist)
 531     {
 532       xfree (prefix_text);
 533       *base_list = elt->prefixlist;
 534       return result;
 535     }
 536
 537   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
 538   xfree (prefix_text);
 539   xfree (result);
 540   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 541   gdbscm_dynwind_xfree (msg);
 542   gdbscm_out_of_range_error (func_name, arg_pos,
 543                              gdbscm_scm_from_c_string (name), msg);
 544   /* NOTREACHED */
 545 }
 546
 547 static const scheme_integer_constant command_classes[] =
 548 {
 549   /* Note: alias and user are special; pseudo appears to be unused,
 550      and there is no reason to expose tui, I think.  */
 551   { "COMMAND_NONE", no_class },
 552   { "COMMAND_RUNNING", class_run },
 553   { "COMMAND_DATA", class_vars },
 554   { "COMMAND_STACK", class_stack },
 555   { "COMMAND_FILES", class_files },
 556   { "COMMAND_SUPPORT", class_support },
 557   { "COMMAND_STATUS", class_info },
 558   { "COMMAND_BREAKPOINTS", class_breakpoint },
 559   { "COMMAND_TRACEPOINTS", class_trace },
 560   { "COMMAND_OBSCURE", class_obscure },
 561   { "COMMAND_MAINTENANCE", class_maintenance },
 562   { "COMMAND_USER", class_user },
 563
 564   END_INTEGER_CONSTANTS
 565 };
 566
 567 /* Return non-zero if command_class is a valid command class.  */
 568
 569 int
 570 gdbscm_valid_command_class_p (int command_class)
 571 {
 572   int i;
 573
 574   for (i = 0; command_classes[i].name != NULL; ++i)
 575     {
 576       if (command_classes[i].value == command_class)
 577         return 1;
 578     }
 579
 580   return 0;
 581 }
 582
 583 /* Return a normalized form of command NAME.
 584    That is tabs are replaced with spaces and multiple spaces are replaced
 585    with a single space.
 586    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
 587    prefix commands.
 588    but that is the caller's responsibility.
 589    Space for the result is allocated on the GC heap.  */
 590
 591 char *
 592 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 593 {
 594   int i, out, seen_word;
 595   char *result
 596     = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
 597
 598   i = out = seen_word = 0;
 599   while (name[i])
 600     {
 601       /* Skip whitespace.  */
 602       while (name[i] == ' ' || name[i] == '\t')
 603         ++i;
 604       /* Copy non-whitespace characters.  */
 605       if (name[i])
 606         {
 607           if (seen_word)
 608             result[out++] = ' ';
 609           while (name[i] && name[i] != ' ' && name[i] != '\t')
 610             result[out++] = name[i++];
 611           seen_word = 1;
 612         }
 613     }
 614   if (want_trailing_space)
 615     result[out++] = ' ';
 616   result[out] = '\0';
 617
 618   return result;
 619 }
 620
 621 /* (make-command name [#:invoke lambda]
 622      [#:command-class class] [#:completer-class completer]
 623      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
 624
 625    NAME is the name of the command.  It may consist of multiple words,
 626    in which case the final word is the name of the new command, and
 627    earlier words must be prefix commands.
 628
 629    INVOKE is a procedure of three arguments that performs the command when
 630    invoked: (lambda (self arg from-tty) ...).
 631    Its result is unspecified.
 632
 633    CLASS is the kind of command.  It must be one of the COMMAND_*
 634    constants defined in the gdb module.  If not specified, "no_class" is used.
 635
 636    COMPLETER is the kind of completer.  It must be either:
 637      #f - completion is not supported for this command.
 638      One of the COMPLETE_* constants defined in the gdb module.
 639      A procedure of three arguments: (lambda (self text word) ...).
 640        Its result is one of:
 641          A list of strings.
 642          A <gdb:iterator> object that returns the set of possible completions,
 643          ending with #f.
 644          TODO(dje): Once PR 16699 is fixed, add support for returning
 645          a COMPLETE_* constant.
 646    If not specified, then completion is not supported for this command.
 647
 648    If PREFIX is #t, then this command is a prefix command.
 649
 650    DOC is the doc string for the command.
 651
 652    The result is the <gdb:command> Scheme object.
 653    The command is not available to be used yet, however.
 654    It must still be added to gdb with register-command!.  */
 655
 656 static SCM
 657 gdbscm_make_command (SCM name_scm, SCM rest)
 658 {
 659   const SCM keywords[] = {
 660     invoke_keyword, command_class_keyword, completer_class_keyword,
 661     prefix_p_keyword, doc_keyword, SCM_BOOL_F
 662   };
 663   int invoke_arg_pos = -1, command_class_arg_pos = 1;
 664   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
 665   int doc_arg_pos = -1;
 666   char *s;
 667   char *name;
 668   enum command_class command_class = no_class;
 669   SCM completer_class = SCM_BOOL_F;
 670   int is_prefix = 0;
 671   char *doc = NULL;
 672   SCM invoke = SCM_BOOL_F;
 673   SCM c_scm;
 674   command_smob *c_smob;
 675
 676   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
 677                               name_scm, &name, rest,
 678                               &invoke_arg_pos, &invoke,
 679                               &command_class_arg_pos, &command_class,
 680                               &completer_class_arg_pos, &completer_class,
 681                               &is_prefix_arg_pos, &is_prefix,
 682                               &doc_arg_pos, &doc);
 683
 684   if (doc == NULL)
 685     doc = xstrdup (_("This command is not documented."));
 686
 687   s = name;
 688   name = gdbscm_canonicalize_command_name (s, is_prefix);
 689   xfree (s);
 690   s = doc;
 691   doc = gdbscm_gc_xstrdup (s);
 692   xfree (s);
 693
 694   if (is_prefix
 695       ? name[0] == ' '
 696       : name[0] == '\0')
 697     {
 698       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
 699                                  _("no command name found"));
 700     }
 701
 702   if (gdbscm_is_true (invoke))
 703     {
 704       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
 705                        invoke_arg_pos, FUNC_NAME, _("procedure"));
 706     }
 707
 708   if (!gdbscm_valid_command_class_p (command_class))
 709     {
 710       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
 711                                  scm_from_int (command_class),
 712                                  _("invalid command class argument"));
 713     }
 714
 715   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
 716                    || scm_is_integer (completer_class)
 717                    || gdbscm_is_procedure (completer_class),
 718                    completer_class, completer_class_arg_pos, FUNC_NAME,
 719                    _("integer or procedure"));
 720   if (scm_is_integer (completer_class)
 721       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
 722     {
 723       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
 724                                  completer_class,
 725                                  _("invalid completion type argument"));
 726     }
 727
 728   c_scm = cmdscm_make_command_smob ();
 729   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 730   c_smob->name = name;
 731   c_smob->is_prefix = is_prefix;
 732   c_smob->cmd_class = command_class;
 733   c_smob->doc = doc;
 734   c_smob->invoke = invoke;
 735   c_smob->complete = completer_class;
 736
 737   return c_scm;
 738 }
 739
 740 /* (register-command! <gdb:command>) -> unspecified
 741
 742    It is an error to register a command more than once.  */
 743
 744 static SCM
 745 gdbscm_register_command_x (SCM self)
 746 {
 747   command_smob *c_smob
 748     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 749   char *cmd_name;
 750   struct cmd_list_element **cmd_list;
 751   struct cmd_list_element *cmd = NULL;
 752
 753   if (cmdscm_is_valid (c_smob))
 754     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
 755
 756   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
 757                                         &cmd_list, &cmdlist);
 758   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
 759   xfree (cmd_name);
 760
 761   gdbscm_gdb_exception exc {};
 762   try
 763     {
 764       if (c_smob->is_prefix)
 765         {
 766           /* If we have our own "invoke" method, then allow unknown
 767              sub-commands.  */
 768           int allow_unknown = gdbscm_is_true (c_smob->invoke);
 769
 770           cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class,
 771                                 NULL, c_smob->doc, &c_smob->sub_list,
 772                                 c_smob->name, allow_unknown, cmd_list);
 773         }
 774       else
 775         {
 776           cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class,
 777                          c_smob->doc, cmd_list);
 778         }
 779     }
 780   catch (const gdb_exception &except)
 781     {
 782       exc = unpack (except);
 783     }
 784   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 785
 786   /* Note: At this point the command exists in gdb.
 787      So no more errors after this point.  */
 788
 789   /* There appears to be no API to set this.  */
 790   cmd->func = cmdscm_function;
 791   cmd->destroyer = cmdscm_destroyer;
 792
 793   c_smob->command = cmd;
 794   set_cmd_context (cmd, c_smob);
 795
 796   if (gdbscm_is_true (c_smob->complete))
 797     {
 798       set_cmd_completer (cmd,
 799                          scm_is_integer (c_smob->complete)
 800                          ? cmdscm_completers[scm_to_int (c_smob->complete)].completer
 801                          : cmdscm_completer);
 802     }
 803
 804   /* The owner of this command is not in GC-controlled memory, so we need
 805      to protect it from GC until the command is deleted.  */
 806   scm_gc_protect_object (c_smob->containing_scm);
 807
 808   return SCM_UNSPECIFIED;
 809 }
 810 \f
 811 /* Initialize the Scheme command support.  */
 812
 813 static const scheme_function command_functions[] =
 814 {
 815   { "make-command", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_command),
 816     "\
 817 Make a GDB command object.\n\
 818 \n\
 819   Arguments: name [#:invoke lambda]\n\
 820       [#:command-class <class>] [#:completer-class <completer>]\n\
 821       [#:prefix? <bool>] [#:doc string]\n\
 822     name: The name of the command.  It may consist of multiple words,\n\
 823       in which case the final word is the name of the new command, and\n\
 824       earlier words must be prefix commands.\n\
 825     invoke: A procedure of three arguments to perform the command.\n\
 826       (lambda (self arg from-tty) ...)\n\
 827       Its result is unspecified.\n\
 828     class: The class of the command, one of COMMAND_*.\n\
 829       The default is COMMAND_NONE.\n\
 830     completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
 831       to perform the completion: (lambda (self text word) ...).\n\
 832     prefix?: If true then the command is a prefix command.\n\
 833     doc: The \"doc string\" of the command.\n\
 834   Returns: <gdb:command> object" },
 835
 836   { "register-command!", 1, 0, 0, as_a_scm_t_subr (gdbscm_register_command_x),
 837     "\
 838 Register a <gdb:command> object with GDB." },
 839
 840   { "command?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_p),
 841     "\
 842 Return #t if the object is a <gdb:command> object." },
 843
 844   { "command-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_valid_p),
 845     "\
 846 Return #t if the <gdb:command> object is valid." },
 847
 848   { "dont-repeat", 1, 0, 0, as_a_scm_t_subr (gdbscm_dont_repeat),
 849     "\
 850 Prevent command repetition when user enters an empty line.\n\
 851 \n\
 852   Arguments: <gdb:command>\n\
 853   Returns: unspecified" },
 854
 855   END_FUNCTIONS
 856 };
 857
 858 /* Initialize the 'commands' code.  */
 859
 860 void
 861 gdbscm_initialize_commands (void)
 862 {
 863   int i;
 864
 865   command_smob_tag
 866     = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
 867   scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
 868
 869   gdbscm_define_integer_constants (command_classes, 1);
 870   gdbscm_define_functions (command_functions, 1);
 871
 872   for (i = 0; i < N_COMPLETERS; ++i)
 873     {
 874       scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
 875       scm_c_export (cmdscm_completers[i].name, NULL);
 876     }
 877
 878   invoke_keyword = scm_from_latin1_keyword ("invoke");
 879   command_class_keyword = scm_from_latin1_keyword ("command-class");
 880   completer_class_keyword = scm_from_latin1_keyword ("completer-class");
 881   prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
 882   doc_keyword = scm_from_latin1_keyword ("doc");
 883 }