ice-9/debugger/command-loop.scm

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