gdb/guile/scm-cmd.c

   1 /* GDB commands implemented in Scheme.
   2
   3    Copyright (C) 2008-2014 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", make_symbol_completion_list_fn },
 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   /* We allocated the name, doc string, and perhaps the prefix name.  */
 291   xfree ((char *) self->name);
 292   xfree ((char *) self->doc);
 293   xfree ((char *) self->prefixname);
 294 }
 295
 296 /* Called by gdb to invoke the command.  */
 297
 298 static void
 299 cmdscm_function (struct cmd_list_element *command, char *args, int from_tty)
 300 {
 301   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 302   SCM arg_scm, tty_scm, result;
 303
 304   gdb_assert (c_smob != NULL);
 305
 306   if (args == NULL)
 307     args = "";
 308   arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
 309   if (gdbscm_is_exception (arg_scm))
 310     error (_("Could not convert arguments to Scheme string."));
 311
 312   tty_scm = scm_from_bool (from_tty);
 313
 314   result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
 315                                arg_scm, tty_scm, gdbscm_user_error_p);
 316
 317   if (gdbscm_is_exception (result))
 318     {
 319       /* Don't print the stack if this was an error signalled by the command
 320          itself.  */
 321       if (gdbscm_user_error_p (gdbscm_exception_key (result)))
 322         {
 323           char *msg = gdbscm_exception_message_to_string (result);
 324
 325           make_cleanup (xfree, msg);
 326           error ("%s", msg);
 327         }
 328       else
 329         {
 330           gdbscm_print_gdb_exception (SCM_BOOL_F, result);
 331           error (_("Error occurred in Scheme-implemented GDB command."));
 332         }
 333     }
 334 }
 335
 336 /* Subroutine of cmdscm_completer to simplify it.
 337    Print an error message indicating that COMPLETION is a bad completion
 338    result.  */
 339
 340 static void
 341 cmdscm_bad_completion_result (const char *msg, SCM completion)
 342 {
 343   SCM port = scm_current_error_port ();
 344
 345   scm_puts (msg, port);
 346   scm_display (completion, port);
 347   scm_newline (port);
 348 }
 349
 350 /* Subroutine of cmdscm_completer to simplify it.
 351    Validate COMPLETION and add to RESULT.
 352    If an error occurs print an error message.
 353    The result is a boolean indicating success.  */
 354
 355 static int
 356 cmdscm_add_completion (SCM completion, VEC (char_ptr) **result)
 357 {
 358   char *item;
 359   SCM except_scm;
 360
 361   if (!scm_is_string (completion))
 362     {
 363       /* Inform the user, but otherwise ignore the entire result.  */
 364       cmdscm_bad_completion_result (_("Bad text from completer: "),
 365                                     completion);
 366       return 0;
 367     }
 368
 369   item = gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
 370                                &except_scm);
 371   if (item == NULL)
 372     {
 373       /* Inform the user, but otherwise ignore the entire result.  */
 374       gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
 375       return 0;
 376     }
 377
 378   VEC_safe_push (char_ptr, *result, item);
 379
 380   return 1;
 381 }
 382
 383 /* Called by gdb for command completion.  */
 384
 385 static VEC (char_ptr) *
 386 cmdscm_completer (struct cmd_list_element *command,
 387                   const char *text, const char *word)
 388 {
 389   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 390   SCM completer_result_scm;
 391   SCM text_scm, word_scm, result_scm;
 392   VEC (char_ptr) *result = NULL;
 393
 394   gdb_assert (c_smob != NULL);
 395   gdb_assert (gdbscm_is_procedure (c_smob->complete));
 396
 397   text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
 398                                      1);
 399   if (gdbscm_is_exception (text_scm))
 400     error (_("Could not convert \"text\" argument to Scheme string."));
 401   word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
 402                                      1);
 403   if (gdbscm_is_exception (word_scm))
 404     error (_("Could not convert \"word\" argument to Scheme string."));
 405
 406   completer_result_scm
 407     = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
 408                           text_scm, word_scm, NULL);
 409
 410   if (gdbscm_is_exception (completer_result_scm))
 411     {
 412       /* Inform the user, but otherwise ignore.  */
 413       gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 414       goto done;
 415     }
 416
 417   if (gdbscm_is_true (scm_list_p (completer_result_scm)))
 418     {
 419       SCM list = completer_result_scm;
 420
 421       while (!scm_is_eq (list, SCM_EOL))
 422         {
 423           SCM next = scm_car (list);
 424
 425           if (!cmdscm_add_completion (next, &result))
 426             {
 427               VEC_free (char_ptr, result);
 428               goto done;
 429             }
 430
 431           list = scm_cdr (list);
 432         }
 433     }
 434   else if (itscm_is_iterator (completer_result_scm))
 435     {
 436       SCM iter = completer_result_scm;
 437       SCM next = itscm_safe_call_next_x (iter, NULL);
 438
 439       while (gdbscm_is_true (next))
 440         {
 441           if (gdbscm_is_exception (next))
 442             {
 443               /* Inform the user, but otherwise ignore the entire result.  */
 444               gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 445               VEC_free (char_ptr, result);
 446               goto done;
 447             }
 448
 449           if (!cmdscm_add_completion (next, &result))
 450             {
 451               VEC_free (char_ptr, result);
 452               goto done;
 453             }
 454
 455           next = itscm_safe_call_next_x (iter, NULL);
 456         }
 457     }
 458   else
 459     {
 460       /* Inform the user, but otherwise ignore.  */
 461       cmdscm_bad_completion_result (_("Bad completer result: "),
 462                                     completer_result_scm);
 463     }
 464
 465  done:
 466   return result;
 467 }
 468
 469 /* Helper for gdbscm_make_command which locates the command list to use and
 470    pulls out the command name.
 471
 472    NAME is the command name list.  The final word in the list is the
 473    name of the new command.  All earlier words must be existing prefix
 474    commands.
 475
 476    *BASE_LIST is set to the final prefix command's list of
 477    *sub-commands.
 478
 479    START_LIST is the list in which the search starts.
 480
 481    This function returns the xmalloc()d name of the new command.
 482    On error a Scheme exception is thrown.  */
 483
 484 char *
 485 gdbscm_parse_command_name (const char *name,
 486                            const char *func_name, int arg_pos,
 487                            struct cmd_list_element ***base_list,
 488                            struct cmd_list_element **start_list)
 489 {
 490   struct cmd_list_element *elt;
 491   int len = strlen (name);
 492   int i, lastchar;
 493   char *prefix_text;
 494   const char *prefix_text2;
 495   char *result, *msg;
 496
 497   /* Skip trailing whitespace.  */
 498   for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 499     ;
 500   if (i < 0)
 501     {
 502       gdbscm_out_of_range_error (func_name, arg_pos,
 503                                  gdbscm_scm_from_c_string (name),
 504                                  _("no command name found"));
 505     }
 506   lastchar = i;
 507
 508   /* Find first character of the final word.  */
 509   for (; i > 0 && (isalnum (name[i - 1])
 510                    || name[i - 1] == '-'
 511                    || name[i - 1] == '_');
 512        --i)
 513     ;
 514   result = xmalloc (lastchar - i + 2);
 515   memcpy (result, &name[i], lastchar - i + 1);
 516   result[lastchar - i + 1] = '\0';
 517
 518   /* Skip whitespace again.  */
 519   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 520     ;
 521   if (i < 0)
 522     {
 523       *base_list = start_list;
 524       return result;
 525     }
 526
 527   prefix_text = xmalloc (i + 2);
 528   memcpy (prefix_text, name, i + 1);
 529   prefix_text[i + 1] = '\0';
 530
 531   prefix_text2 = prefix_text;
 532   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
 533   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
 534     {
 535       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
 536       xfree (prefix_text);
 537       xfree (result);
 538       scm_dynwind_begin (0);
 539       gdbscm_dynwind_xfree (msg);
 540       gdbscm_out_of_range_error (func_name, arg_pos,
 541                                  gdbscm_scm_from_c_string (name), msg);
 542     }
 543
 544   if (elt->prefixlist)
 545     {
 546       xfree (prefix_text);
 547       *base_list = elt->prefixlist;
 548       return result;
 549     }
 550
 551   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
 552   xfree (prefix_text);
 553   xfree (result);
 554   scm_dynwind_begin (0);
 555   gdbscm_dynwind_xfree (msg);
 556   gdbscm_out_of_range_error (func_name, arg_pos,
 557                              gdbscm_scm_from_c_string (name), msg);
 558   /* NOTREACHED */
 559 }
 560
 561 static const scheme_integer_constant command_classes[] =
 562 {
 563   /* Note: alias and user are special; pseudo appears to be unused,
 564      and there is no reason to expose tui or xdb, I think.  */
 565   { "COMMAND_NONE", no_class },
 566   { "COMMAND_RUNNING", class_run },
 567   { "COMMAND_DATA", class_vars },
 568   { "COMMAND_STACK", class_stack },
 569   { "COMMAND_FILES", class_files },
 570   { "COMMAND_SUPPORT", class_support },
 571   { "COMMAND_STATUS", class_info },
 572   { "COMMAND_BREAKPOINTS", class_breakpoint },
 573   { "COMMAND_TRACEPOINTS", class_trace },
 574   { "COMMAND_OBSCURE", class_obscure },
 575   { "COMMAND_MAINTENANCE", class_maintenance },
 576   { "COMMAND_USER", class_user },
 577
 578   END_INTEGER_CONSTANTS
 579 };
 580
 581 /* Return non-zero if command_class is a valid command class.  */
 582
 583 int
 584 gdbscm_valid_command_class_p (int command_class)
 585 {
 586   int i;
 587
 588   for (i = 0; command_classes[i].name != NULL; ++i)
 589     {
 590       if (command_classes[i].value == command_class)
 591         return 1;
 592     }
 593
 594   return 0;
 595 }
 596
 597 /* Return a normalized form of command NAME.
 598    That is tabs are replaced with spaces and multiple spaces are replaced
 599    with a single space.
 600    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
 601    prefix commands.
 602    but that is the caller's responsibility.
 603    Space for the result is allocated on the GC heap.  */
 604
 605 char *
 606 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 607 {
 608   int i, out, seen_word;
 609   char *result = scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
 610
 611   i = out = seen_word = 0;
 612   while (name[i])
 613     {
 614       /* Skip whitespace.  */
 615       while (name[i] == ' ' || name[i] == '\t')
 616         ++i;
 617       /* Copy non-whitespace characters.  */
 618       if (name[i])
 619         {
 620           if (seen_word)
 621             result[out++] = ' ';
 622           while (name[i] && name[i] != ' ' && name[i] != '\t')
 623             result[out++] = name[i++];
 624           seen_word = 1;
 625         }
 626     }
 627   if (want_trailing_space)
 628     result[out++] = ' ';
 629   result[out] = '\0';
 630
 631   return result;
 632 }
 633
 634 /* (make-command name [#:invoke lambda]
 635      [#:command-class class] [#:completer-class completer]
 636      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
 637
 638    NAME is the name of the command.  It may consist of multiple words,
 639    in which case the final word is the name of the new command, and
 640    earlier words must be prefix commands.
 641
 642    INVOKE is a procedure of three arguments that performs the command when
 643    invoked: (lambda (self arg from-tty) ...).
 644    Its result is unspecified.
 645
 646    CLASS is the kind of command.  It must be one of the COMMAND_*
 647    constants defined in the gdb module.  If not specified, "no_class" is used.
 648
 649    COMPLETER is the kind of completer.  It must be either:
 650      #f - completion is not supported for this command.
 651      One of the COMPLETE_* constants defined in the gdb module.
 652      A procedure of three arguments: (lambda (self text word) ...).
 653        Its result is one of:
 654          A list of strings.
 655          A <gdb:iterator> object that returns the set of possible completions,
 656          ending with #f.
 657          TODO(dje): Once PR 16699 is fixed, add support for returning
 658          a COMPLETE_* constant.
 659    If not specified, then completion is not supported for this command.
 660
 661    If PREFIX is #t, then this command is a prefix command.
 662
 663    DOC is the doc string for the command.
 664
 665    The result is the <gdb:command> Scheme object.
 666    The command is not available to be used yet, however.
 667    It must still be added to gdb with register-command!.  */
 668
 669 static SCM
 670 gdbscm_make_command (SCM name_scm, SCM rest)
 671 {
 672   const SCM keywords[] = {
 673     invoke_keyword, command_class_keyword, completer_class_keyword,
 674     prefix_p_keyword, doc_keyword, SCM_BOOL_F
 675   };
 676   int invoke_arg_pos = -1, command_class_arg_pos = 1;
 677   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
 678   int doc_arg_pos = -1;
 679   char *s;
 680   char *name;
 681   int command_class = no_class;
 682   SCM completer_class = SCM_BOOL_F;
 683   int is_prefix = 0;
 684   char *doc = NULL;
 685   SCM invoke = SCM_BOOL_F;
 686   SCM c_scm;
 687   command_smob *c_smob;
 688
 689   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
 690                               name_scm, &name, rest,
 691                               &invoke_arg_pos, &invoke,
 692                               &command_class_arg_pos, &command_class,
 693                               &completer_class_arg_pos, &completer_class,
 694                               &is_prefix_arg_pos, &is_prefix,
 695                               &doc_arg_pos, &doc);
 696
 697   if (doc == NULL)
 698     doc = xstrdup (_("This command is not documented."));
 699
 700   s = name;
 701   name = gdbscm_canonicalize_command_name (s, is_prefix);
 702   xfree (s);
 703   s = doc;
 704   doc = gdbscm_gc_xstrdup (s);
 705   xfree (s);
 706
 707   if (is_prefix
 708       ? name[0] == ' '
 709       : name[0] == '\0')
 710     {
 711       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
 712                                  _("no command name found"));
 713     }
 714
 715   if (gdbscm_is_true (invoke))
 716     {
 717       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
 718                        invoke_arg_pos, FUNC_NAME, _("procedure"));
 719     }
 720
 721   if (!gdbscm_valid_command_class_p (command_class))
 722     {
 723       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
 724                                  scm_from_int (command_class),
 725                                  _("invalid command class argument"));
 726     }
 727
 728   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
 729                    || scm_is_integer (completer_class)
 730                    || gdbscm_is_procedure (completer_class),
 731                    completer_class, completer_class_arg_pos, FUNC_NAME,
 732                    _("integer or procedure"));
 733   if (scm_is_integer (completer_class)
 734       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
 735     {
 736       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
 737                                  completer_class,
 738                                  _("invalid completion type argument"));
 739     }
 740
 741   c_scm = cmdscm_make_command_smob ();
 742   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 743   c_smob->name = name;
 744   c_smob->is_prefix = is_prefix;
 745   c_smob->cmd_class = command_class;
 746   c_smob->doc = doc;
 747   c_smob->invoke = invoke;
 748   c_smob->complete = completer_class;
 749
 750   return c_scm;
 751 }
 752
 753 /* (register-command! <gdb:command>) -> unspecified
 754
 755    It is an error to register a command more than once.  */
 756
 757 static SCM
 758 gdbscm_register_command_x (SCM self)
 759 {
 760   command_smob *c_smob
 761     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 762   char *cmd_name, *pfx_name;
 763   struct cmd_list_element **cmd_list;
 764   struct cmd_list_element *cmd = NULL;
 765   volatile struct gdb_exception except;
 766
 767   if (cmdscm_is_valid (c_smob))
 768     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
 769
 770   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
 771                                         &cmd_list, &cmdlist);
 772   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
 773   xfree (cmd_name);
 774
 775   TRY_CATCH (except, RETURN_MASK_ALL)
 776     {
 777       if (c_smob->is_prefix)
 778         {
 779           /* If we have our own "invoke" method, then allow unknown
 780              sub-commands.  */
 781           int allow_unknown = gdbscm_is_true (c_smob->invoke);
 782
 783           cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class,
 784                                 NULL, c_smob->doc, &c_smob->sub_list,
 785                                 c_smob->name, allow_unknown, cmd_list);
 786         }
 787       else
 788         {
 789           cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class,
 790                          NULL, c_smob->doc, cmd_list);
 791         }
 792     }
 793   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 794
 795   /* Note: At this point the command exists in gdb.
 796      So no more errors after this point.  */
 797
 798   /* There appears to be no API to set this.  */
 799   cmd->func = cmdscm_function;
 800   cmd->destroyer = cmdscm_destroyer;
 801
 802   c_smob->command = cmd;
 803   set_cmd_context (cmd, c_smob);
 804
 805   if (gdbscm_is_true (c_smob->complete))
 806     {
 807       set_cmd_completer (cmd,
 808                          scm_is_integer (c_smob->complete)
 809                          ? cmdscm_completers[scm_to_int (c_smob->complete)].completer
 810                          : cmdscm_completer);
 811     }
 812
 813   /* The owner of this command is not in GC-controlled memory, so we need
 814      to protect it from GC until the command is deleted.  */
 815   scm_gc_protect_object (c_smob->containing_scm);
 816
 817   return SCM_UNSPECIFIED;
 818 }
 819 \f
 820 /* Initialize the Scheme command support.  */
 821
 822 static const scheme_function command_functions[] =
 823 {
 824   { "make-command", 1, 0, 1, gdbscm_make_command,
 825     "\
 826 Make a GDB command object.\n\
 827 \n\
 828   Arguments: name [#:invoke lambda]\n\
 829       [#:command-class <class>] [#:completer-class <completer>]\n\
 830       [#:prefix? <bool>] [#:doc string]\n\
 831     name: The name of the command.  It may consist of multiple words,\n\
 832       in which case the final word is the name of the new command, and\n\
 833       earlier words must be prefix commands.\n\
 834     invoke: A procedure of three arguments to perform the command.\n\
 835       (lambda (self arg from-tty) ...)\n\
 836       Its result is unspecified.\n\
 837     class: The class of the command, one of COMMAND_*.\n\
 838       The default is COMMAND_NONE.\n\
 839     completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
 840       to perform the completion: (lambda (self text word) ...).\n\
 841     prefix?: If true then the command is a prefix command.\n\
 842     doc: The \"doc string\" of the command.\n\
 843   Returns: <gdb:command> object" },
 844
 845   { "register-command!", 1, 0, 0, gdbscm_register_command_x,
 846     "\
 847 Register a <gdb:command> object with GDB." },
 848
 849   { "command?", 1, 0, 0, gdbscm_command_p,
 850     "\
 851 Return #t if the object is a <gdb:command> object." },
 852
 853   { "command-valid?", 1, 0, 0, gdbscm_command_valid_p,
 854     "\
 855 Return #t if the <gdb:command> object is valid." },
 856
 857   { "dont-repeat", 1, 0, 0, gdbscm_dont_repeat,
 858     "\
 859 Prevent command repetition when user enters an empty line.\n\
 860 \n\
 861   Arguments: <gdb:command>\n\
 862   Returns: unspecified" },
 863
 864   END_FUNCTIONS
 865 };
 866
 867 /* Initialize the 'commands' code.  */
 868
 869 void
 870 gdbscm_initialize_commands (void)
 871 {
 872   int i;
 873
 874   command_smob_tag
 875     = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
 876   scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
 877
 878   gdbscm_define_integer_constants (command_classes, 1);
 879   gdbscm_define_functions (command_functions, 1);
 880
 881   for (i = 0; i < N_COMPLETERS; ++i)
 882     {
 883       scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
 884       scm_c_export (cmdscm_completers[i].name, NULL);
 885     }
 886
 887   invoke_keyword = scm_from_latin1_keyword ("invoke");
 888   command_class_keyword = scm_from_latin1_keyword ("command-class");
 889   completer_class_keyword = scm_from_latin1_keyword ("completer-class");
 890   prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
 891   doc_keyword = scm_from_latin1_keyword ("doc");
 892 }