gdb/guile/scm-cmd.c

   1 /* GDB commands implemented in Scheme.
   2
   3    Copyright (C) 2008-2017 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   command_smob *c_smob
 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                  char *args_entry, int from_tty)
 296 {
 297   const char *args = args_entry;
 298   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 299   SCM arg_scm, tty_scm, result;
 300
 301   gdb_assert (c_smob != NULL);
 302
 303   if (args == NULL)
 304     args = "";
 305   arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
 306   if (gdbscm_is_exception (arg_scm))
 307     error (_("Could not convert arguments to Scheme string."));
 308
 309   tty_scm = scm_from_bool (from_tty);
 310
 311   result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
 312                                arg_scm, tty_scm, gdbscm_user_error_p);
 313
 314   if (gdbscm_is_exception (result))
 315     {
 316       /* Don't print the stack if this was an error signalled by the command
 317          itself.  */
 318       if (gdbscm_user_error_p (gdbscm_exception_key (result)))
 319         {
 320           char *msg = gdbscm_exception_message_to_string (result);
 321
 322           make_cleanup (xfree, msg);
 323           error ("%s", msg);
 324         }
 325       else
 326         {
 327           gdbscm_print_gdb_exception (SCM_BOOL_F, result);
 328           error (_("Error occurred in Scheme-implemented GDB command."));
 329         }
 330     }
 331 }
 332
 333 /* Subroutine of cmdscm_completer to simplify it.
 334    Print an error message indicating that COMPLETION is a bad completion
 335    result.  */
 336
 337 static void
 338 cmdscm_bad_completion_result (const char *msg, SCM completion)
 339 {
 340   SCM port = scm_current_error_port ();
 341
 342   scm_puts (msg, port);
 343   scm_display (completion, port);
 344   scm_newline (port);
 345 }
 346
 347 /* Subroutine of cmdscm_completer to simplify it.
 348    Validate COMPLETION and add to RESULT.
 349    If an error occurs print an error message.
 350    The result is a boolean indicating success.  */
 351
 352 static int
 353 cmdscm_add_completion (SCM completion, completion_tracker &tracker)
 354 {
 355   SCM except_scm;
 356
 357   if (!scm_is_string (completion))
 358     {
 359       /* Inform the user, but otherwise ignore the entire result.  */
 360       cmdscm_bad_completion_result (_("Bad text from completer: "),
 361                                     completion);
 362       return 0;
 363     }
 364
 365   gdb::unique_xmalloc_ptr<char> item
 366     (gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
 367                            &except_scm));
 368   if (item == NULL)
 369     {
 370       /* Inform the user, but otherwise ignore the entire result.  */
 371       gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
 372       return 0;
 373     }
 374
 375   tracker.add_completion (std::move (item));
 376
 377   return 1;
 378 }
 379
 380 /* Called by gdb for command completion.  */
 381
 382 static void
 383 cmdscm_completer (struct cmd_list_element *command,
 384                   completion_tracker &tracker,
 385                   const char *text, const char *word)
 386 {
 387   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 388   SCM completer_result_scm;
 389   SCM text_scm, word_scm, result_scm;
 390
 391   gdb_assert (c_smob != NULL);
 392   gdb_assert (gdbscm_is_procedure (c_smob->complete));
 393
 394   text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
 395                                      1);
 396   if (gdbscm_is_exception (text_scm))
 397     error (_("Could not convert \"text\" argument to Scheme string."));
 398   word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
 399                                      1);
 400   if (gdbscm_is_exception (word_scm))
 401     error (_("Could not convert \"word\" argument to Scheme string."));
 402
 403   completer_result_scm
 404     = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
 405                           text_scm, word_scm, NULL);
 406
 407   if (gdbscm_is_exception (completer_result_scm))
 408     {
 409       /* Inform the user, but otherwise ignore.  */
 410       gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 411       return;
 412     }
 413
 414   if (gdbscm_is_true (scm_list_p (completer_result_scm)))
 415     {
 416       SCM list = completer_result_scm;
 417
 418       while (!scm_is_eq (list, SCM_EOL))
 419         {
 420           SCM next = scm_car (list);
 421
 422           if (!cmdscm_add_completion (next, tracker))
 423             break;
 424
 425           list = scm_cdr (list);
 426         }
 427     }
 428   else if (itscm_is_iterator (completer_result_scm))
 429     {
 430       SCM iter = completer_result_scm;
 431       SCM next = itscm_safe_call_next_x (iter, NULL);
 432
 433       while (gdbscm_is_true (next))
 434         {
 435           if (gdbscm_is_exception (next))
 436             {
 437               /* Inform the user.  */
 438               gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 439               break;
 440             }
 441
 442           if (cmdscm_add_completion (next, tracker))
 443             break;
 444
 445           next = itscm_safe_call_next_x (iter, NULL);
 446         }
 447     }
 448   else
 449     {
 450       /* Inform the user, but otherwise ignore.  */
 451       cmdscm_bad_completion_result (_("Bad completer result: "),
 452                                     completer_result_scm);
 453     }
 454 }
 455
 456 /* Helper for gdbscm_make_command which locates the command list to use and
 457    pulls out the command name.
 458
 459    NAME is the command name list.  The final word in the list is the
 460    name of the new command.  All earlier words must be existing prefix
 461    commands.
 462
 463    *BASE_LIST is set to the final prefix command's list of
 464    *sub-commands.
 465
 466    START_LIST is the list in which the search starts.
 467
 468    This function returns the xmalloc()d name of the new command.
 469    On error a Scheme exception is thrown.  */
 470
 471 char *
 472 gdbscm_parse_command_name (const char *name,
 473                            const char *func_name, int arg_pos,
 474                            struct cmd_list_element ***base_list,
 475                            struct cmd_list_element **start_list)
 476 {
 477   struct cmd_list_element *elt;
 478   int len = strlen (name);
 479   int i, lastchar;
 480   char *prefix_text;
 481   const char *prefix_text2;
 482   char *result, *msg;
 483
 484   /* Skip trailing whitespace.  */
 485   for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 486     ;
 487   if (i < 0)
 488     {
 489       gdbscm_out_of_range_error (func_name, arg_pos,
 490                                  gdbscm_scm_from_c_string (name),
 491                                  _("no command name found"));
 492     }
 493   lastchar = i;
 494
 495   /* Find first character of the final word.  */
 496   for (; i > 0 && (isalnum (name[i - 1])
 497                    || name[i - 1] == '-'
 498                    || name[i - 1] == '_');
 499        --i)
 500     ;
 501   result = (char *) xmalloc (lastchar - i + 2);
 502   memcpy (result, &name[i], lastchar - i + 1);
 503   result[lastchar - i + 1] = '\0';
 504
 505   /* Skip whitespace again.  */
 506   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 507     ;
 508   if (i < 0)
 509     {
 510       *base_list = start_list;
 511       return result;
 512     }
 513
 514   prefix_text = (char *) xmalloc (i + 2);
 515   memcpy (prefix_text, name, i + 1);
 516   prefix_text[i + 1] = '\0';
 517
 518   prefix_text2 = prefix_text;
 519   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
 520   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
 521     {
 522       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
 523       xfree (prefix_text);
 524       xfree (result);
 525       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 526       gdbscm_dynwind_xfree (msg);
 527       gdbscm_out_of_range_error (func_name, arg_pos,
 528                                  gdbscm_scm_from_c_string (name), msg);
 529     }
 530
 531   if (elt->prefixlist)
 532     {
 533       xfree (prefix_text);
 534       *base_list = elt->prefixlist;
 535       return result;
 536     }
 537
 538   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
 539   xfree (prefix_text);
 540   xfree (result);
 541   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 542   gdbscm_dynwind_xfree (msg);
 543   gdbscm_out_of_range_error (func_name, arg_pos,
 544                              gdbscm_scm_from_c_string (name), msg);
 545   /* NOTREACHED */
 546 }
 547
 548 static const scheme_integer_constant command_classes[] =
 549 {
 550   /* Note: alias and user are special; pseudo appears to be unused,
 551      and there is no reason to expose tui, I think.  */
 552   { "COMMAND_NONE", no_class },
 553   { "COMMAND_RUNNING", class_run },
 554   { "COMMAND_DATA", class_vars },
 555   { "COMMAND_STACK", class_stack },
 556   { "COMMAND_FILES", class_files },
 557   { "COMMAND_SUPPORT", class_support },
 558   { "COMMAND_STATUS", class_info },
 559   { "COMMAND_BREAKPOINTS", class_breakpoint },
 560   { "COMMAND_TRACEPOINTS", class_trace },
 561   { "COMMAND_OBSCURE", class_obscure },
 562   { "COMMAND_MAINTENANCE", class_maintenance },
 563   { "COMMAND_USER", class_user },
 564
 565   END_INTEGER_CONSTANTS
 566 };
 567
 568 /* Return non-zero if command_class is a valid command class.  */
 569
 570 int
 571 gdbscm_valid_command_class_p (int command_class)
 572 {
 573   int i;
 574
 575   for (i = 0; command_classes[i].name != NULL; ++i)
 576     {
 577       if (command_classes[i].value == command_class)
 578         return 1;
 579     }
 580
 581   return 0;
 582 }
 583
 584 /* Return a normalized form of command NAME.
 585    That is tabs are replaced with spaces and multiple spaces are replaced
 586    with a single space.
 587    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
 588    prefix commands.
 589    but that is the caller's responsibility.
 590    Space for the result is allocated on the GC heap.  */
 591
 592 char *
 593 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 594 {
 595   int i, out, seen_word;
 596   char *result
 597     = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
 598
 599   i = out = seen_word = 0;
 600   while (name[i])
 601     {
 602       /* Skip whitespace.  */
 603       while (name[i] == ' ' || name[i] == '\t')
 604         ++i;
 605       /* Copy non-whitespace characters.  */
 606       if (name[i])
 607         {
 608           if (seen_word)
 609             result[out++] = ' ';
 610           while (name[i] && name[i] != ' ' && name[i] != '\t')
 611             result[out++] = name[i++];
 612           seen_word = 1;
 613         }
 614     }
 615   if (want_trailing_space)
 616     result[out++] = ' ';
 617   result[out] = '\0';
 618
 619   return result;
 620 }
 621
 622 /* (make-command name [#:invoke lambda]
 623      [#:command-class class] [#:completer-class completer]
 624      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
 625
 626    NAME is the name of the command.  It may consist of multiple words,
 627    in which case the final word is the name of the new command, and
 628    earlier words must be prefix commands.
 629
 630    INVOKE is a procedure of three arguments that performs the command when
 631    invoked: (lambda (self arg from-tty) ...).
 632    Its result is unspecified.
 633
 634    CLASS is the kind of command.  It must be one of the COMMAND_*
 635    constants defined in the gdb module.  If not specified, "no_class" is used.
 636
 637    COMPLETER is the kind of completer.  It must be either:
 638      #f - completion is not supported for this command.
 639      One of the COMPLETE_* constants defined in the gdb module.
 640      A procedure of three arguments: (lambda (self text word) ...).
 641        Its result is one of:
 642          A list of strings.
 643          A <gdb:iterator> object that returns the set of possible completions,
 644          ending with #f.
 645          TODO(dje): Once PR 16699 is fixed, add support for returning
 646          a COMPLETE_* constant.
 647    If not specified, then completion is not supported for this command.
 648
 649    If PREFIX is #t, then this command is a prefix command.
 650
 651    DOC is the doc string for the command.
 652
 653    The result is the <gdb:command> Scheme object.
 654    The command is not available to be used yet, however.
 655    It must still be added to gdb with register-command!.  */
 656
 657 static SCM
 658 gdbscm_make_command (SCM name_scm, SCM rest)
 659 {
 660   const SCM keywords[] = {
 661     invoke_keyword, command_class_keyword, completer_class_keyword,
 662     prefix_p_keyword, doc_keyword, SCM_BOOL_F
 663   };
 664   int invoke_arg_pos = -1, command_class_arg_pos = 1;
 665   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
 666   int doc_arg_pos = -1;
 667   char *s;
 668   char *name;
 669   enum command_class command_class = no_class;
 670   SCM completer_class = SCM_BOOL_F;
 671   int is_prefix = 0;
 672   char *doc = NULL;
 673   SCM invoke = SCM_BOOL_F;
 674   SCM c_scm;
 675   command_smob *c_smob;
 676
 677   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
 678                               name_scm, &name, rest,
 679                               &invoke_arg_pos, &invoke,
 680                               &command_class_arg_pos, &command_class,
 681                               &completer_class_arg_pos, &completer_class,
 682                               &is_prefix_arg_pos, &is_prefix,
 683                               &doc_arg_pos, &doc);
 684
 685   if (doc == NULL)
 686     doc = xstrdup (_("This command is not documented."));
 687
 688   s = name;
 689   name = gdbscm_canonicalize_command_name (s, is_prefix);
 690   xfree (s);
 691   s = doc;
 692   doc = gdbscm_gc_xstrdup (s);
 693   xfree (s);
 694
 695   if (is_prefix
 696       ? name[0] == ' '
 697       : name[0] == '\0')
 698     {
 699       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
 700                                  _("no command name found"));
 701     }
 702
 703   if (gdbscm_is_true (invoke))
 704     {
 705       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
 706                        invoke_arg_pos, FUNC_NAME, _("procedure"));
 707     }
 708
 709   if (!gdbscm_valid_command_class_p (command_class))
 710     {
 711       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
 712                                  scm_from_int (command_class),
 713                                  _("invalid command class argument"));
 714     }
 715
 716   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
 717                    || scm_is_integer (completer_class)
 718                    || gdbscm_is_procedure (completer_class),
 719                    completer_class, completer_class_arg_pos, FUNC_NAME,
 720                    _("integer or procedure"));
 721   if (scm_is_integer (completer_class)
 722       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
 723     {
 724       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
 725                                  completer_class,
 726                                  _("invalid completion type argument"));
 727     }
 728
 729   c_scm = cmdscm_make_command_smob ();
 730   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 731   c_smob->name = name;
 732   c_smob->is_prefix = is_prefix;
 733   c_smob->cmd_class = command_class;
 734   c_smob->doc = doc;
 735   c_smob->invoke = invoke;
 736   c_smob->complete = completer_class;
 737
 738   return c_scm;
 739 }
 740
 741 /* (register-command! <gdb:command>) -> unspecified
 742
 743    It is an error to register a command more than once.  */
 744
 745 static SCM
 746 gdbscm_register_command_x (SCM self)
 747 {
 748   command_smob *c_smob
 749     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 750   char *cmd_name, *pfx_name;
 751   struct cmd_list_element **cmd_list;
 752   struct cmd_list_element *cmd = NULL;
 753
 754   if (cmdscm_is_valid (c_smob))
 755     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
 756
 757   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
 758                                         &cmd_list, &cmdlist);
 759   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
 760   xfree (cmd_name);
 761
 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                          NULL, c_smob->doc, cmd_list);
 778         }
 779     }
 780   CATCH (except, RETURN_MASK_ALL)
 781     {
 782       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 783     }
 784   END_CATCH
 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 }