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", 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 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 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 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, VEC (char_ptr) **result) 354 { 355 char *item; 356 SCM except_scm; 357 358 if (!scm_is_string (completion)) 359 { 360 /* Inform the user, but otherwise ignore the entire result. */ 361 cmdscm_bad_completion_result (_("Bad text from completer: "), 362 completion); 363 return 0; 364 } 365 366 item = 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 VEC_safe_push (char_ptr, *result, item); 376 377 return 1; 378 } 379 380 /* Called by gdb for command completion. */ 381 382 static VEC (char_ptr) * 383 cmdscm_completer (struct cmd_list_element *command, 384 const char *text, const char *word) 385 { 386 command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command); 387 SCM completer_result_scm; 388 SCM text_scm, word_scm, result_scm; 389 VEC (char_ptr) *result = NULL; 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 goto done; 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, &result)) 423 { 424 VEC_free (char_ptr, result); 425 goto done; 426 } 427 428 list = scm_cdr (list); 429 } 430 } 431 else if (itscm_is_iterator (completer_result_scm)) 432 { 433 SCM iter = completer_result_scm; 434 SCM next = itscm_safe_call_next_x (iter, NULL); 435 436 while (gdbscm_is_true (next)) 437 { 438 if (gdbscm_is_exception (next)) 439 { 440 /* Inform the user, but otherwise ignore the entire result. */ 441 gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm); 442 VEC_free (char_ptr, result); 443 goto done; 444 } 445 446 if (!cmdscm_add_completion (next, &result)) 447 { 448 VEC_free (char_ptr, result); 449 goto done; 450 } 451 452 next = itscm_safe_call_next_x (iter, NULL); 453 } 454 } 455 else 456 { 457 /* Inform the user, but otherwise ignore. */ 458 cmdscm_bad_completion_result (_("Bad completer result: "), 459 completer_result_scm); 460 } 461 462 done: 463 return result; 464 } 465 466 /* Helper for gdbscm_make_command which locates the command list to use and 467 pulls out the command name. 468 469 NAME is the command name list. The final word in the list is the 470 name of the new command. All earlier words must be existing prefix 471 commands. 472 473 *BASE_LIST is set to the final prefix command's list of 474 *sub-commands. 475 476 START_LIST is the list in which the search starts. 477 478 This function returns the xmalloc()d name of the new command. 479 On error a Scheme exception is thrown. */ 480 481 char * 482 gdbscm_parse_command_name (const char *name, 483 const char *func_name, int arg_pos, 484 struct cmd_list_element ***base_list, 485 struct cmd_list_element **start_list) 486 { 487 struct cmd_list_element *elt; 488 int len = strlen (name); 489 int i, lastchar; 490 char *prefix_text; 491 const char *prefix_text2; 492 char *result, *msg; 493 494 /* Skip trailing whitespace. */ 495 for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i) 496 ; 497 if (i < 0) 498 { 499 gdbscm_out_of_range_error (func_name, arg_pos, 500 gdbscm_scm_from_c_string (name), 501 _("no command name found")); 502 } 503 lastchar = i; 504 505 /* Find first character of the final word. */ 506 for (; i > 0 && (isalnum (name[i - 1]) 507 || name[i - 1] == '-' 508 || name[i - 1] == '_'); 509 --i) 510 ; 511 result = (char *) xmalloc (lastchar - i + 2); 512 memcpy (result, &name[i], lastchar - i + 1); 513 result[lastchar - i + 1] = '\0'; 514 515 /* Skip whitespace again. */ 516 for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i) 517 ; 518 if (i < 0) 519 { 520 *base_list = start_list; 521 return result; 522 } 523 524 prefix_text = (char *) xmalloc (i + 2); 525 memcpy (prefix_text, name, i + 1); 526 prefix_text[i + 1] = '\0'; 527 528 prefix_text2 = prefix_text; 529 elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1); 530 if (elt == NULL || elt == CMD_LIST_AMBIGUOUS) 531 { 532 msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text); 533 xfree (prefix_text); 534 xfree (result); 535 scm_dynwind_begin ((scm_t_dynwind_flags) 0); 536 gdbscm_dynwind_xfree (msg); 537 gdbscm_out_of_range_error (func_name, arg_pos, 538 gdbscm_scm_from_c_string (name), msg); 539 } 540 541 if (elt->prefixlist) 542 { 543 xfree (prefix_text); 544 *base_list = elt->prefixlist; 545 return result; 546 } 547 548 msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text); 549 xfree (prefix_text); 550 xfree (result); 551 scm_dynwind_begin ((scm_t_dynwind_flags) 0); 552 gdbscm_dynwind_xfree (msg); 553 gdbscm_out_of_range_error (func_name, arg_pos, 554 gdbscm_scm_from_c_string (name), msg); 555 /* NOTREACHED */ 556 } 557 558 static const scheme_integer_constant command_classes[] = 559 { 560 /* Note: alias and user are special; pseudo appears to be unused, 561 and there is no reason to expose tui, I think. */ 562 { "COMMAND_NONE", no_class }, 563 { "COMMAND_RUNNING", class_run }, 564 { "COMMAND_DATA", class_vars }, 565 { "COMMAND_STACK", class_stack }, 566 { "COMMAND_FILES", class_files }, 567 { "COMMAND_SUPPORT", class_support }, 568 { "COMMAND_STATUS", class_info }, 569 { "COMMAND_BREAKPOINTS", class_breakpoint }, 570 { "COMMAND_TRACEPOINTS", class_trace }, 571 { "COMMAND_OBSCURE", class_obscure }, 572 { "COMMAND_MAINTENANCE", class_maintenance }, 573 { "COMMAND_USER", class_user }, 574 575 END_INTEGER_CONSTANTS 576 }; 577 578 /* Return non-zero if command_class is a valid command class. */ 579 580 int 581 gdbscm_valid_command_class_p (int command_class) 582 { 583 int i; 584 585 for (i = 0; command_classes[i].name != NULL; ++i) 586 { 587 if (command_classes[i].value == command_class) 588 return 1; 589 } 590 591 return 0; 592 } 593 594 /* Return a normalized form of command NAME. 595 That is tabs are replaced with spaces and multiple spaces are replaced 596 with a single space. 597 If WANT_TRAILING_SPACE is non-zero, add one space at the end. This is for 598 prefix commands. 599 but that is the caller's responsibility. 600 Space for the result is allocated on the GC heap. */ 601 602 char * 603 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space) 604 { 605 int i, out, seen_word; 606 char *result 607 = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME); 608 609 i = out = seen_word = 0; 610 while (name[i]) 611 { 612 /* Skip whitespace. */ 613 while (name[i] == ' ' || name[i] == '\t') 614 ++i; 615 /* Copy non-whitespace characters. */ 616 if (name[i]) 617 { 618 if (seen_word) 619 result[out++] = ' '; 620 while (name[i] && name[i] != ' ' && name[i] != '\t') 621 result[out++] = name[i++]; 622 seen_word = 1; 623 } 624 } 625 if (want_trailing_space) 626 result[out++] = ' '; 627 result[out] = '\0'; 628 629 return result; 630 } 631 632 /* (make-command name [#:invoke lambda] 633 [#:command-class class] [#:completer-class completer] 634 [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command> 635 636 NAME is the name of the command. It may consist of multiple words, 637 in which case the final word is the name of the new command, and 638 earlier words must be prefix commands. 639 640 INVOKE is a procedure of three arguments that performs the command when 641 invoked: (lambda (self arg from-tty) ...). 642 Its result is unspecified. 643 644 CLASS is the kind of command. It must be one of the COMMAND_* 645 constants defined in the gdb module. If not specified, "no_class" is used. 646 647 COMPLETER is the kind of completer. It must be either: 648 #f - completion is not supported for this command. 649 One of the COMPLETE_* constants defined in the gdb module. 650 A procedure of three arguments: (lambda (self text word) ...). 651 Its result is one of: 652 A list of strings. 653 A <gdb:iterator> object that returns the set of possible completions, 654 ending with #f. 655 TODO(dje): Once PR 16699 is fixed, add support for returning 656 a COMPLETE_* constant. 657 If not specified, then completion is not supported for this command. 658 659 If PREFIX is #t, then this command is a prefix command. 660 661 DOC is the doc string for the command. 662 663 The result is the <gdb:command> Scheme object. 664 The command is not available to be used yet, however. 665 It must still be added to gdb with register-command!. */ 666 667 static SCM 668 gdbscm_make_command (SCM name_scm, SCM rest) 669 { 670 const SCM keywords[] = { 671 invoke_keyword, command_class_keyword, completer_class_keyword, 672 prefix_p_keyword, doc_keyword, SCM_BOOL_F 673 }; 674 int invoke_arg_pos = -1, command_class_arg_pos = 1; 675 int completer_class_arg_pos = -1, is_prefix_arg_pos = -1; 676 int doc_arg_pos = -1; 677 char *s; 678 char *name; 679 enum command_class command_class = no_class; 680 SCM completer_class = SCM_BOOL_F; 681 int is_prefix = 0; 682 char *doc = NULL; 683 SCM invoke = SCM_BOOL_F; 684 SCM c_scm; 685 command_smob *c_smob; 686 687 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts", 688 name_scm, &name, rest, 689 &invoke_arg_pos, &invoke, 690 &command_class_arg_pos, &command_class, 691 &completer_class_arg_pos, &completer_class, 692 &is_prefix_arg_pos, &is_prefix, 693 &doc_arg_pos, &doc); 694 695 if (doc == NULL) 696 doc = xstrdup (_("This command is not documented.")); 697 698 s = name; 699 name = gdbscm_canonicalize_command_name (s, is_prefix); 700 xfree (s); 701 s = doc; 702 doc = gdbscm_gc_xstrdup (s); 703 xfree (s); 704 705 if (is_prefix 706 ? name[0] == ' ' 707 : name[0] == '\0') 708 { 709 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm, 710 _("no command name found")); 711 } 712 713 if (gdbscm_is_true (invoke)) 714 { 715 SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke, 716 invoke_arg_pos, FUNC_NAME, _("procedure")); 717 } 718 719 if (!gdbscm_valid_command_class_p (command_class)) 720 { 721 gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos, 722 scm_from_int (command_class), 723 _("invalid command class argument")); 724 } 725 726 SCM_ASSERT_TYPE (gdbscm_is_false (completer_class) 727 || scm_is_integer (completer_class) 728 || gdbscm_is_procedure (completer_class), 729 completer_class, completer_class_arg_pos, FUNC_NAME, 730 _("integer or procedure")); 731 if (scm_is_integer (completer_class) 732 && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1)) 733 { 734 gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos, 735 completer_class, 736 _("invalid completion type argument")); 737 } 738 739 c_scm = cmdscm_make_command_smob (); 740 c_smob = (command_smob *) SCM_SMOB_DATA (c_scm); 741 c_smob->name = name; 742 c_smob->is_prefix = is_prefix; 743 c_smob->cmd_class = command_class; 744 c_smob->doc = doc; 745 c_smob->invoke = invoke; 746 c_smob->complete = completer_class; 747 748 return c_scm; 749 } 750 751 /* (register-command! <gdb:command>) -> unspecified 752 753 It is an error to register a command more than once. */ 754 755 static SCM 756 gdbscm_register_command_x (SCM self) 757 { 758 command_smob *c_smob 759 = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); 760 char *cmd_name, *pfx_name; 761 struct cmd_list_element **cmd_list; 762 struct cmd_list_element *cmd = NULL; 763 764 if (cmdscm_is_valid (c_smob)) 765 scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL); 766 767 cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1, 768 &cmd_list, &cmdlist); 769 c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name); 770 xfree (cmd_name); 771 772 TRY 773 { 774 if (c_smob->is_prefix) 775 { 776 /* If we have our own "invoke" method, then allow unknown 777 sub-commands. */ 778 int allow_unknown = gdbscm_is_true (c_smob->invoke); 779 780 cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class, 781 NULL, c_smob->doc, &c_smob->sub_list, 782 c_smob->name, allow_unknown, cmd_list); 783 } 784 else 785 { 786 cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class, 787 NULL, c_smob->doc, cmd_list); 788 } 789 } 790 CATCH (except, RETURN_MASK_ALL) 791 { 792 GDBSCM_HANDLE_GDB_EXCEPTION (except); 793 } 794 END_CATCH 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 821 /* Initialize the Scheme command support. */ 822 823 static const scheme_function command_functions[] = 824 { 825 { "make-command", 1, 0, 1, as_a_scm_t_subr (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, as_a_scm_t_subr (gdbscm_register_command_x), 847 "\ 848 Register a <gdb:command> object with GDB." }, 849 850 { "command?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_p), 851 "\ 852 Return #t if the object is a <gdb:command> object." }, 853 854 { "command-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_valid_p), 855 "\ 856 Return #t if the <gdb:command> object is valid." }, 857 858 { "dont-repeat", 1, 0, 0, as_a_scm_t_subr (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 } 894