ice-9/debugger/command-loop.scm

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