gdb/guile/scm-cmd.c

   1 /* GDB commands implemented in Scheme.
   2
   3    Copyright (C) 2008-2020 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 && valid_cmd_char_p (name[i - 1]); --i)
 496     ;
 497   result = (char *) xmalloc (lastchar - i + 2);
 498   memcpy (result, &name[i], lastchar - i + 1);
 499   result[lastchar - i + 1] = '\0';
 500
 501   /* Skip whitespace again.  */
 502   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 503     ;
 504   if (i < 0)
 505     {
 506       *base_list = start_list;
 507       return result;
 508     }
 509
 510   prefix_text = (char *) xmalloc (i + 2);
 511   memcpy (prefix_text, name, i + 1);
 512   prefix_text[i + 1] = '\0';
 513
 514   prefix_text2 = prefix_text;
 515   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
 516   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
 517     {
 518       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
 519       xfree (prefix_text);
 520       xfree (result);
 521       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 522       gdbscm_dynwind_xfree (msg);
 523       gdbscm_out_of_range_error (func_name, arg_pos,
 524                                  gdbscm_scm_from_c_string (name), msg);
 525     }
 526
 527   if (elt->prefixlist)
 528     {
 529       xfree (prefix_text);
 530       *base_list = elt->prefixlist;
 531       return result;
 532     }
 533
 534   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
 535   xfree (prefix_text);
 536   xfree (result);
 537   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 538   gdbscm_dynwind_xfree (msg);
 539   gdbscm_out_of_range_error (func_name, arg_pos,
 540                              gdbscm_scm_from_c_string (name), msg);
 541   /* NOTREACHED */
 542 }
 543
 544 static const scheme_integer_constant command_classes[] =
 545 {
 546   /* Note: alias and user are special; pseudo appears to be unused,
 547      and there is no reason to expose tui, I think.  */
 548   { "COMMAND_NONE", no_class },
 549   { "COMMAND_RUNNING", class_run },
 550   { "COMMAND_DATA", class_vars },
 551   { "COMMAND_STACK", class_stack },
 552   { "COMMAND_FILES", class_files },
 553   { "COMMAND_SUPPORT", class_support },
 554   { "COMMAND_STATUS", class_info },
 555   { "COMMAND_BREAKPOINTS", class_breakpoint },
 556   { "COMMAND_TRACEPOINTS", class_trace },
 557   { "COMMAND_OBSCURE", class_obscure },
 558   { "COMMAND_MAINTENANCE", class_maintenance },
 559   { "COMMAND_USER", class_user },
 560
 561   END_INTEGER_CONSTANTS
 562 };
 563
 564 /* Return non-zero if command_class is a valid command class.  */
 565
 566 int
 567 gdbscm_valid_command_class_p (int command_class)
 568 {
 569   int i;
 570
 571   for (i = 0; command_classes[i].name != NULL; ++i)
 572     {
 573       if (command_classes[i].value == command_class)
 574         return 1;
 575     }
 576
 577   return 0;
 578 }
 579
 580 /* Return a normalized form of command NAME.
 581    That is tabs are replaced with spaces and multiple spaces are replaced
 582    with a single space.
 583    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
 584    prefix commands.
 585    but that is the caller's responsibility.
 586    Space for the result is allocated on the GC heap.  */
 587
 588 char *
 589 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 590 {
 591   int i, out, seen_word;
 592   char *result
 593     = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
 594
 595   i = out = seen_word = 0;
 596   while (name[i])
 597     {
 598       /* Skip whitespace.  */
 599       while (name[i] == ' ' || name[i] == '\t')
 600         ++i;
 601       /* Copy non-whitespace characters.  */
 602       if (name[i])
 603         {
 604           if (seen_word)
 605             result[out++] = ' ';
 606           while (name[i] && name[i] != ' ' && name[i] != '\t')
 607             result[out++] = name[i++];
 608           seen_word = 1;
 609         }
 610     }
 611   if (want_trailing_space)
 612     result[out++] = ' ';
 613   result[out] = '\0';
 614
 615   return result;
 616 }
 617
 618 /* (make-command name [#:invoke lambda]
 619      [#:command-class class] [#:completer-class completer]
 620      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
 621
 622    NAME is the name of the command.  It may consist of multiple words,
 623    in which case the final word is the name of the new command, and
 624    earlier words must be prefix commands.
 625
 626    INVOKE is a procedure of three arguments that performs the command when
 627    invoked: (lambda (self arg from-tty) ...).
 628    Its result is unspecified.
 629
 630    CLASS is the kind of command.  It must be one of the COMMAND_*
 631    constants defined in the gdb module.  If not specified, "no_class" is used.
 632
 633    COMPLETER is the kind of completer.  It must be either:
 634      #f - completion is not supported for this command.
 635      One of the COMPLETE_* constants defined in the gdb module.
 636      A procedure of three arguments: (lambda (self text word) ...).
 637        Its result is one of:
 638          A list of strings.
 639          A <gdb:iterator> object that returns the set of possible completions,
 640          ending with #f.
 641          TODO(dje): Once PR 16699 is fixed, add support for returning
 642          a COMPLETE_* constant.
 643    If not specified, then completion is not supported for this command.
 644
 645    If PREFIX is #t, then this command is a prefix command.
 646
 647    DOC is the doc string for the command.
 648
 649    The result is the <gdb:command> Scheme object.
 650    The command is not available to be used yet, however.
 651    It must still be added to gdb with register-command!.  */
 652
 653 static SCM
 654 gdbscm_make_command (SCM name_scm, SCM rest)
 655 {
 656   const SCM keywords[] = {
 657     invoke_keyword, command_class_keyword, completer_class_keyword,
 658     prefix_p_keyword, doc_keyword, SCM_BOOL_F
 659   };
 660   int invoke_arg_pos = -1, command_class_arg_pos = 1;
 661   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
 662   int doc_arg_pos = -1;
 663   char *s;
 664   char *name;
 665   enum command_class command_class = no_class;
 666   SCM completer_class = SCM_BOOL_F;
 667   int is_prefix = 0;
 668   char *doc = NULL;
 669   SCM invoke = SCM_BOOL_F;
 670   SCM c_scm;
 671   command_smob *c_smob;
 672
 673   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
 674                               name_scm, &name, rest,
 675                               &invoke_arg_pos, &invoke,
 676                               &command_class_arg_pos, &command_class,
 677                               &completer_class_arg_pos, &completer_class,
 678                               &is_prefix_arg_pos, &is_prefix,
 679                               &doc_arg_pos, &doc);
 680
 681   if (doc == NULL)
 682     doc = xstrdup (_("This command is not documented."));
 683
 684   s = name;
 685   name = gdbscm_canonicalize_command_name (s, is_prefix);
 686   xfree (s);
 687   s = doc;
 688   doc = gdbscm_gc_xstrdup (s);
 689   xfree (s);
 690
 691   if (is_prefix
 692       ? name[0] == ' '
 693       : name[0] == '\0')
 694     {
 695       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
 696                                  _("no command name found"));
 697     }
 698
 699   if (gdbscm_is_true (invoke))
 700     {
 701       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
 702                        invoke_arg_pos, FUNC_NAME, _("procedure"));
 703     }
 704
 705   if (!gdbscm_valid_command_class_p (command_class))
 706     {
 707       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
 708                                  scm_from_int (command_class),
 709                                  _("invalid command class argument"));
 710     }
 711
 712   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
 713                    || scm_is_integer (completer_class)
 714                    || gdbscm_is_procedure (completer_class),
 715                    completer_class, completer_class_arg_pos, FUNC_NAME,
 716                    _("integer or procedure"));
 717   if (scm_is_integer (completer_class)
 718       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
 719     {
 720       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
 721                                  completer_class,
 722                                  _("invalid completion type argument"));
 723     }
 724
 725   c_scm = cmdscm_make_command_smob ();
 726   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 727   c_smob->name = name;
 728   c_smob->is_prefix = is_prefix;
 729   c_smob->cmd_class = command_class;
 730   c_smob->doc = doc;
 731   c_smob->invoke = invoke;
 732   c_smob->complete = completer_class;
 733
 734   return c_scm;
 735 }
 736
 737 /* (register-command! <gdb:command>) -> unspecified
 738
 739    It is an error to register a command more than once.  */
 740
 741 static SCM
 742 gdbscm_register_command_x (SCM self)
 743 {
 744   command_smob *c_smob
 745     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 746   char *cmd_name;
 747   struct cmd_list_element **cmd_list;
 748   struct cmd_list_element *cmd = NULL;
 749
 750   if (cmdscm_is_valid (c_smob))
 751     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
 752
 753   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
 754                                         &cmd_list, &cmdlist);
 755   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
 756   xfree (cmd_name);
 757
 758   gdbscm_gdb_exception exc {};
 759   try
 760     {
 761       if (c_smob->is_prefix)
 762         {
 763           /* If we have our own "invoke" method, then allow unknown
 764              sub-commands.  */
 765           int allow_unknown = gdbscm_is_true (c_smob->invoke);
 766
 767           cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class,
 768                                 NULL, c_smob->doc, &c_smob->sub_list,
 769                                 c_smob->name, allow_unknown, cmd_list);
 770         }
 771       else
 772         {
 773           cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class,
 774                          c_smob->doc, cmd_list);
 775         }
 776     }
 777   catch (const gdb_exception &except)
 778     {
 779       exc = unpack (except);
 780     }
 781   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 782
 783   /* Note: At this point the command exists in gdb.
 784      So no more errors after this point.  */
 785
 786   /* There appears to be no API to set this.  */
 787   cmd->func = cmdscm_function;
 788   cmd->destroyer = cmdscm_destroyer;
 789
 790   c_smob->command = cmd;
 791   set_cmd_context (cmd, c_smob);
 792
 793   if (gdbscm_is_true (c_smob->complete))
 794     {
 795       set_cmd_completer (cmd,
 796                          scm_is_integer (c_smob->complete)
 797                          ? cmdscm_completers[scm_to_int (c_smob->complete)].completer
 798                          : cmdscm_completer);
 799     }
 800
 801   /* The owner of this command is not in GC-controlled memory, so we need
 802      to protect it from GC until the command is deleted.  */
 803   scm_gc_protect_object (c_smob->containing_scm);
 804
 805   return SCM_UNSPECIFIED;
 806 }
 807 \f
 808 /* Initialize the Scheme command support.  */
 809
 810 static const scheme_function command_functions[] =
 811 {
 812   { "make-command", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_command),
 813     "\
 814 Make a GDB command object.\n\
 815 \n\
 816   Arguments: name [#:invoke lambda]\n\
 817       [#:command-class <class>] [#:completer-class <completer>]\n\
 818       [#:prefix? <bool>] [#:doc string]\n\
 819     name: The name of the command.  It may consist of multiple words,\n\
 820       in which case the final word is the name of the new command, and\n\
 821       earlier words must be prefix commands.\n\
 822     invoke: A procedure of three arguments to perform the command.\n\
 823       (lambda (self arg from-tty) ...)\n\
 824       Its result is unspecified.\n\
 825     class: The class of the command, one of COMMAND_*.\n\
 826       The default is COMMAND_NONE.\n\
 827     completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
 828       to perform the completion: (lambda (self text word) ...).\n\
 829     prefix?: If true then the command is a prefix command.\n\
 830     doc: The \"doc string\" of the command.\n\
 831   Returns: <gdb:command> object" },
 832
 833   { "register-command!", 1, 0, 0, as_a_scm_t_subr (gdbscm_register_command_x),
 834     "\
 835 Register a <gdb:command> object with GDB." },
 836
 837   { "command?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_p),
 838     "\
 839 Return #t if the object is a <gdb:command> object." },
 840
 841   { "command-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_valid_p),
 842     "\
 843 Return #t if the <gdb:command> object is valid." },
 844
 845   { "dont-repeat", 1, 0, 0, as_a_scm_t_subr (gdbscm_dont_repeat),
 846     "\
 847 Prevent command repetition when user enters an empty line.\n\
 848 \n\
 849   Arguments: <gdb:command>\n\
 850   Returns: unspecified" },
 851
 852   END_FUNCTIONS
 853 };
 854
 855 /* Initialize the 'commands' code.  */
 856
 857 void
 858 gdbscm_initialize_commands (void)
 859 {
 860   int i;
 861
 862   command_smob_tag
 863     = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
 864   scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
 865
 866   gdbscm_define_integer_constants (command_classes, 1);
 867   gdbscm_define_functions (command_functions, 1);
 868
 869   for (i = 0; i < N_COMPLETERS; ++i)
 870     {
 871       scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
 872       scm_c_export (cmdscm_completers[i].name, NULL);
 873     }
 874
 875   invoke_keyword = scm_from_latin1_keyword ("invoke");
 876   command_class_keyword = scm_from_latin1_keyword ("command-class");
 877   completer_class_keyword = scm_from_latin1_keyword ("completer-class");
 878   prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
 879   doc_keyword = scm_from_latin1_keyword ("doc");
 880 }