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