module/ice-9/debugger/command-loop.scm

   1 ;;;; Guile Debugger command loop
   2
   3 ;;; Copyright (C) 1999, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc.
   4 ;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (ice-9 debugger command-loop)
  20   #:use-module ((ice-9 debugger commands) :prefix debugger:)
  21   #:use-module (ice-9 debugger)
  22   #:use-module (ice-9 debugger state)
  23   #:use-module (ice-9 debugging traps)
  24   #:export (debugger-command-loop
  25             debugger-command-loop-error
  26             debugger-command-loop-quit)
  27   #:no-backtrace)
  28
  29 ;;; {Interface used by (ice-9 debugger).}
  30
  31 (define (debugger-command-loop state)
  32   (read-and-dispatch-commands state (current-input-port)))
  33
  34 (define (debugger-command-loop-error message)
  35   (user-error message))
  36
  37 (define (debugger-command-loop-quit)
  38   (throw 'exit-debugger))
  39
  40 ;;; {Implementation.}
  41
  42 (define debugger-prompt "debug> ")
  43
  44 (define (debugger-handler key . args)
  45   (case key
  46     ((exit-debugger) #f)
  47     ((signal)
  48      (apply display-error #f (current-error-port) args))
  49     (else
  50      (display "Internal debugger error:\n")
  51      (save-stack debugger-handler)
  52      (apply throw key args)))
  53   (throw 'exit-debugger))               ;Pop the stack
  54
  55 (define (read-and-dispatch-commands state port)
  56   (catch 'exit-debugger
  57     (lambda ()
  58       (lazy-catch #t
  59         (lambda ()
  60           (with-fluids ((last-command #f))
  61             (let loop ()
  62               (read-and-dispatch-command state port)
  63               (loop))))
  64         debugger-handler))
  65     (lambda args
  66       *unspecified*)))
  67
  68 (define set-readline-prompt! #f)
  69
  70 (define (read-and-dispatch-command state port)
  71   (if (using-readline?)
  72       (begin
  73         ;; Import set-readline-prompt! if we haven't already.
  74         (or set-readline-prompt!
  75             (set! set-readline-prompt!
  76                   (module-ref (resolve-module '(ice-9 readline))
  77                               'set-readline-prompt!)))
  78         (set-readline-prompt! debugger-prompt debugger-prompt))
  79       (display debugger-prompt))
  80   (force-output)                        ;This should not be necessary...
  81   (let ((token (read-token port)))
  82     (cond ((eof-object? token)
  83            (throw 'exit-debugger))
  84           ((not token)
  85            (discard-rest-of-line port)
  86            (catch-user-errors port (lambda () (run-last-command state))))
  87           (else
  88            (catch-user-errors port
  89              (lambda ()
  90                (dispatch-command token command-table state port)))))))
  91
  92 (define (run-last-command state)
  93   (let ((procedure (fluid-ref last-command)))
  94     (if procedure
  95         (procedure state))))
  96
  97 (define (catch-user-errors port thunk)
  98   (catch 'debugger-user-error
  99          thunk
 100          (lambda (key . objects)
 101            (apply user-warning objects)
 102            (discard-rest-of-line port))))
 103
 104 (define last-command (make-fluid))
 105
 106 (define (user-warning . objects)
 107   (for-each (lambda (object)
 108               (display object))
 109             objects)
 110   (newline))
 111
 112 (define (user-error . objects)
 113   (apply throw 'debugger-user-error objects))
 114 \f
 115 ;;;; Command dispatch
 116
 117 (define (dispatch-command string table state port)
 118   (let ((value (command-table-value table string)))
 119     (if value
 120         (dispatch-command/value value state port)
 121         (user-error "Unknown command: " string))))
 122
 123 (define (dispatch-command/value value state port)
 124   (cond ((command? value)
 125          (dispatch-command/command value state port))
 126         ((command-table? value)
 127          (dispatch-command/table value state port))
 128         ((list? value)
 129          (dispatch-command/name value state port))
 130         (else
 131          (error "Unrecognized command-table value: " value))))
 132
 133 (define (dispatch-command/command command state port)
 134   (let ((procedure (command-procedure command))
 135         (arguments ((command-parser command) port)))
 136     (let ((procedure (lambda (state) (apply procedure state arguments))))
 137       (warn-about-extra-args port)
 138       (fluid-set! last-command procedure)
 139       (procedure state))))
 140
 141 (define (warn-about-extra-args port)
 142   ;; **** modify this to show the arguments.
 143   (let ((char (skip-whitespace port)))
 144     (cond ((eof-object? char) #f)
 145           ((char=? #\newline char) (read-char port))
 146           (else
 147            (user-warning "Extra arguments at end of line: "
 148                          (read-rest-of-line port))))))
 149
 150 (define (dispatch-command/table table state port)
 151   (let ((token (read-token port)))
 152     (if (or (eof-object? token)
 153             (not token))
 154         (user-error "Command name too short.")
 155         (dispatch-command token table state port))))
 156
 157 (define (dispatch-command/name name state port)
 158   (let ((value (lookup-command name)))
 159     (cond ((not value)
 160            (apply user-error "Unknown command name: " name))
 161           ((command-table? value)
 162            (apply user-error "Partial command name: " name))
 163           (else
 164            (dispatch-command/value value state port)))))
 165 \f
 166 ;;;; Command definition
 167
 168 (define (define-command name argument-template procedure)
 169   (let ((name (canonicalize-command-name name)))
 170     (add-command name
 171                  (make-command name
 172                                (argument-template->parser argument-template)
 173                                (procedure-documentation procedure)
 174                                procedure)
 175                  command-table)
 176     name))
 177
 178 (define (define-command-alias name1 name2)
 179   (let ((name1 (canonicalize-command-name name1)))
 180     (add-command name1 (canonicalize-command-name name2) command-table)
 181     name1))
 182 \f
 183 (define (argument-template->parser template)
 184   ;; Deliberately handles only cases that occur in "commands.scm".
 185   (cond ((eq? 'tokens template)
 186          (lambda (port)
 187            (let loop ((tokens '()))
 188              (let ((token (read-token port)))
 189                (if (or (eof-object? token)
 190                        (not token))
 191                    (list (reverse! tokens))
 192                    (loop (cons token tokens)))))))
 193         ((null? template)
 194          (lambda (port)
 195            '()))
 196         ((and (pair? template)
 197               (null? (cdr template))
 198               (eq? 'object (car template)))
 199          (lambda (port)
 200            (list (read port))))
 201         ((and (pair? template)
 202               (equal? ''optional (car template))
 203               (pair? (cdr template))
 204               (null? (cddr template)))
 205          (case (cadr template)
 206            ((token)
 207             (lambda (port)
 208               (let ((token (read-token port)))
 209                 (if (or (eof-object? token)
 210                         (not token))
 211                     (list #f)
 212                     (list token)))))
 213            ((exact-integer)
 214             (lambda (port)
 215               (list (parse-optional-exact-integer port))))
 216            ((exact-nonnegative-integer)
 217             (lambda (port)
 218               (list (parse-optional-exact-nonnegative-integer port))))
 219            ((object)
 220             (lambda (port)
 221               (list (parse-optional-object port))))
 222            (else
 223             (error "Malformed argument template: " template))))
 224         (else
 225          (error "Malformed argument template: " template))))
 226
 227 (define (parse-optional-exact-integer port)
 228   (let ((object (parse-optional-object port)))
 229     (if (or (not object)
 230             (and (integer? object)
 231                  (exact? object)))
 232         object
 233         (user-error "Argument not an exact integer: " object))))
 234
 235 (define (parse-optional-exact-nonnegative-integer port)
 236   (let ((object (parse-optional-object port)))
 237     (if (or (not object)
 238             (and (integer? object)
 239                  (exact? object)
 240                  (not (negative? object))))
 241         object
 242         (user-error "Argument not an exact non-negative integer: " object))))
 243
 244 (define (parse-optional-object port)
 245   (let ((terminator (skip-whitespace port)))
 246     (if (or (eof-object? terminator)
 247             (eq? #\newline terminator))
 248         #f
 249         (let ((object (read port)))
 250           (if (eof-object? object)
 251               #f
 252               object)))))
 253 \f
 254 ;;;; Command tables
 255
 256 (define (lookup-command name)
 257   (let loop ((table command-table) (strings name))
 258     (let ((value (command-table-value table (car strings))))
 259       (cond ((or (not value) (null? (cdr strings))) value)
 260             ((command-table? value) (loop value (cdr strings)))
 261             (else #f)))))
 262
 263 (define (command-table-value table string)
 264   (let ((entry (command-table-entry table string)))
 265     (and entry
 266          (caddr entry))))
 267
 268 (define (command-table-entry table string)
 269   (let loop ((entries (command-table-entries table)))
 270     (and (not (null? entries))
 271          (let ((entry (car entries)))
 272            (if (and (<= (cadr entry)
 273                         (string-length string)
 274                         (string-length (car entry)))
 275                     (= (string-length string)
 276                        (match-strings (car entry) string)))
 277                entry
 278                (loop (cdr entries)))))))
 279
 280 (define (match-strings s1 s2)
 281   (let ((n (min (string-length s1) (string-length s2))))
 282     (let loop ((i 0))
 283       (cond ((= i n) i)
 284             ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
 285             (else i)))))
 286
 287 (define (write-command-name name)
 288   (display (car name))
 289   (for-each (lambda (string)
 290               (write-char #\space)
 291               (display string))
 292             (cdr name)))
 293 \f
 294 (define (add-command name value table)
 295   (let loop ((strings name) (table table))
 296     (let ((entry
 297            (or (let loop ((entries (command-table-entries table)))
 298                  (and (not (null? entries))
 299                       (if (string=? (car strings) (caar entries))
 300                           (car entries)
 301                           (loop (cdr entries)))))
 302                (let ((entry (list (car strings) #f #f)))
 303                  (let ((entries
 304                         (let ((entries (command-table-entries table)))
 305                           (if (or (null? entries)
 306                                   (string<? (car strings) (caar entries)))
 307                               (cons entry entries)
 308                               (begin
 309                                 (let loop ((prev entries) (this (cdr entries)))
 310                                   (if (or (null? this)
 311                                           (string<? (car strings) (caar this)))
 312                                       (set-cdr! prev (cons entry this))
 313                                       (loop this (cdr this))))
 314                                 entries)))))
 315                    (compute-string-abbreviations! entries)
 316                    (set-command-table-entries! table entries))
 317                  entry))))
 318       (if (null? (cdr strings))
 319           (set-car! (cddr entry) value)
 320           (loop (cdr strings)
 321                 (if (command-table? (caddr entry))
 322                     (caddr entry)
 323                     (let ((table (make-command-table '())))
 324                       (set-car! (cddr entry) table)
 325                       table)))))))
 326
 327 (define (canonicalize-command-name name)
 328   (cond ((and (string? name)
 329               (not (string-null? name)))
 330          (list name))
 331         ((let loop ((name name))
 332            (and (pair? name)
 333                 (string? (car name))
 334                 (not (string-null? (car name)))
 335                 (or (null? (cdr name))
 336                     (loop (cdr name)))))
 337          name)
 338         (else
 339          (error "Illegal command name: " name))))
 340
 341 (define (compute-string-abbreviations! entries)
 342   (let loop ((entries entries) (index 0))
 343     (let ((groups '()))
 344       (for-each
 345        (lambda (entry)
 346          (let* ((char (string-ref (car entry) index))
 347                 (group (assv char groups)))
 348            (if group
 349                (set-cdr! group (cons entry (cdr group)))
 350                (set! groups
 351                      (cons (list char entry)
 352                            groups)))))
 353        entries)
 354       (for-each
 355        (lambda (group)
 356          (let ((index (+ index 1)))
 357            (if (null? (cddr group))
 358                (set-car! (cdadr group) index)
 359                (loop (let ((entry
 360                             (let loop ((entries (cdr group)))
 361                               (and (not (null? entries))
 362                                    (if (= index (string-length (caar entries)))
 363                                        (car entries)
 364                                        (loop (cdr entries)))))))
 365                        (if entry
 366                            (begin
 367                              (set-car! (cdr entry) index)
 368                              (delq entry (cdr group)))
 369                            (cdr group)))
 370                      index))))
 371        groups))))
 372 \f
 373 ;;;; Data structures
 374
 375 (define command-table-rtd (make-record-type "command-table" '(entries)))
 376 (define make-command-table (record-constructor command-table-rtd '(entries)))
 377 (define command-table? (record-predicate command-table-rtd))
 378 (define command-table-entries (record-accessor command-table-rtd 'entries))
 379 (define set-command-table-entries!
 380   (record-modifier command-table-rtd 'entries))
 381
 382 (define command-rtd
 383   (make-record-type "command"
 384                     '(name parser documentation procedure)))
 385
 386 (define make-command
 387   (record-constructor command-rtd
 388                       '(name parser documentation procedure)))
 389
 390 (define command? (record-predicate command-rtd))
 391 (define command-name (record-accessor command-rtd 'name))
 392 (define command-parser (record-accessor command-rtd 'parser))
 393 (define command-documentation (record-accessor command-rtd 'documentation))
 394 (define command-procedure (record-accessor command-rtd 'procedure))
 395 \f
 396 ;;;; Character parsing
 397
 398 (define (read-token port)
 399   (letrec
 400       ((loop
 401         (lambda (chars)
 402           (let ((char (peek-char port)))
 403             (cond ((eof-object? char)
 404                    (do-eof char chars))
 405                   ((char=? #\newline char)
 406                    (do-eot chars))
 407                   ((char-whitespace? char)
 408                    (do-eot chars))
 409                   ((char=? #\# char)
 410                    (read-char port)
 411                    (let ((terminator (skip-comment port)))
 412                      (if (eof-object? char)
 413                          (do-eof char chars)
 414                          (do-eot chars))))
 415                   (else
 416                    (read-char port)
 417                    (loop (cons char chars)))))))
 418        (do-eof
 419         (lambda (eof chars)
 420           (if (null? chars)
 421               eof
 422               (do-eot chars))))
 423        (do-eot
 424         (lambda (chars)
 425           (if (null? chars)
 426               #f
 427               (list->string (reverse! chars))))))
 428     (skip-whitespace port)
 429     (loop '())))
 430
 431 (define (skip-whitespace port)
 432   (let ((char (peek-char port)))
 433     (cond ((or (eof-object? char)
 434                (char=? #\newline char))
 435            char)
 436           ((char-whitespace? char)
 437            (read-char port)
 438            (skip-whitespace port))
 439           ((char=? #\# char)
 440            (read-char port)
 441            (skip-comment port))
 442           (else char))))
 443
 444 (define (skip-comment port)
 445   (let ((char (peek-char port)))
 446     (if (or (eof-object? char)
 447             (char=? #\newline char))
 448         char
 449         (begin
 450           (read-char port)
 451           (skip-comment port)))))
 452
 453 (define (read-rest-of-line port)
 454   (let loop ((chars '()))
 455     (let ((char (read-char port)))
 456       (if (or (eof-object? char)
 457               (char=? #\newline char))
 458           (list->string (reverse! chars))
 459           (loop (cons char chars))))))
 460
 461 (define (discard-rest-of-line port)
 462   (let loop ()
 463     (if (not (let ((char (read-char port)))
 464                (or (eof-object? char)
 465                    (char=? #\newline char))))
 466         (loop))))
 467 \f
 468 ;;;; Commands
 469
 470 (define command-table (make-command-table '()))
 471
 472 (define-command "help" 'tokens
 473   (lambda (state tokens)
 474     "Type \"help\" followed by a command name for full documentation."
 475     (let loop ((name (if (null? tokens) '("help") tokens)))
 476       (let ((value (lookup-command name)))
 477         (cond ((not value)
 478                (write-command-name name)
 479                (display " is not a known command name.")
 480                (newline))
 481               ((command? value)
 482                (display (command-documentation value))
 483                (newline)
 484                (if (equal? '("help") (command-name value))
 485                    (begin
 486                      (display "Available commands are:")
 487                      (newline)
 488                      (for-each (lambda (entry)
 489                                  (if (not (list? (caddr entry)))
 490                                      (begin
 491                                        (display "  ")
 492                                        (display (car entry))
 493                                        (newline))))
 494                                (command-table-entries command-table)))))
 495               ((command-table? value)
 496                (display "The \"")
 497                (write-command-name name)
 498                (display "\" command requires a subcommand.")
 499                (newline)
 500                (display "Available subcommands are:")
 501                (newline)
 502                (for-each (lambda (entry)
 503                            (if (not (list? (caddr entry)))
 504                                (begin
 505                                  (display "  ")
 506                                  (write-command-name name)
 507                                  (write-char #\space)
 508                                  (display (car entry))
 509                                  (newline))))
 510                          (command-table-entries value)))
 511               ((list? value)
 512                (loop value))
 513               (else
 514                (error "Unknown value from lookup-command:" value)))))
 515     state))
 516
 517 (define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)
 518
 519 (define-command "position" '() debugger:position)
 520
 521 (define-command "up" '('optional exact-integer) debugger:up)
 522
 523 (define-command "down" '('optional exact-integer) debugger:down)
 524 \f
 525 (define-command "backtrace" '('optional exact-integer) debugger:backtrace)
 526
 527 (define-command "evaluate" '(object) debugger:evaluate)
 528
 529 (define-command '("info" "args") '() debugger:info-args)
 530
 531 (define-command '("info" "frame") '() debugger:info-frame)
 532
 533 (define-command "quit" '()
 534   (lambda (state)
 535     "Exit the debugger."
 536     (debugger-command-loop-quit)))
 537
 538 (define-command-alias "f" "frame")
 539 (define-command-alias '("info" "f") '("info" "frame"))
 540 (define-command-alias "bt" "backtrace")
 541 (define-command-alias "where" "backtrace")
 542 (define-command-alias "p" "evaluate")
 543 (define-command-alias '("info" "stack") "backtrace")
 544
 545 (define-command "continue" '() debugger:continue)
 546
 547 (define-command "finish" '() debugger:finish)
 548
 549 (define-command "step" '('optional exact-integer) debugger:step)
 550
 551 (define-command "next" '('optional exact-integer) debugger:next)