share/guile/1.6.0/ice-9/debugger.scm

   1 ;;;; Guile Debugger
   2
   3 ;;; Copyright (C) 1999, 2001 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)
  45   :use-module (ice-9 debug)
  46   :use-module (ice-9 format)
  47   :export (debug)
  48   :no-backtrace
  49   )
  50
  51 (if (memq 'readline *features*)
  52     (define-module (ice-9 debugger)
  53       :use-module (ice-9 readline)))
  54
  55 \f
  56 (define debugger-prompt "debug> ")
  57
  58 (define (debug)
  59   (let ((stack (fluid-ref the-last-stack)))
  60     (if stack
  61         (let ((state (make-state stack 0)))
  62           (display "This is the Guile debugger; type \"help\" for help.")
  63           (newline)
  64           (display "There are ")
  65           (write (stack-length stack))
  66           (display " frames on the stack.")
  67           (newline)
  68           (newline)
  69           (write-state-short state)
  70           (read-and-dispatch-commands state (current-input-port)))
  71         (display "Nothing to debug.\n"))))
  72
  73 (define (debugger-handler key . args)
  74   (case key
  75     ((exit-debugger) #f)
  76     ((signal)
  77      ;; Restore stack
  78      (fluid-set! the-last-stack (fluid-ref before-signal-stack))
  79      (apply display-error #f (current-error-port) args))
  80     (else
  81      (display "Internal debugger error:\n")
  82      (save-stack debugger-handler)
  83      (apply throw key args)))
  84   (throw 'exit-debugger))               ;Pop the stack
  85
  86 (define (read-and-dispatch-commands state port)
  87   (catch 'exit-debugger
  88     (lambda ()
  89       (lazy-catch #t
  90         (lambda ()
  91           (with-fluids ((last-command #f))
  92             (let loop ((state state))
  93               (loop (read-and-dispatch-command state port)))))
  94         debugger-handler))
  95     (lambda args
  96       *unspecified*)))
  97
  98 (define (read-and-dispatch-command state port)
  99   (if (using-readline?)
 100       (set-readline-prompt! debugger-prompt)
 101       (display debugger-prompt))
 102   (force-output)                        ;This should not be necessary...
 103   (let ((token (read-token port)))
 104     (cond ((eof-object? token)
 105            (throw 'exit-debugger))
 106           ((not token)
 107            (discard-rest-of-line port)
 108            (catch-user-errors port (lambda () (run-last-command state))))
 109           (else
 110            (or (catch-user-errors port
 111                  (lambda ()
 112                    (dispatch-command token command-table state port)))
 113                state)))))
 114
 115 (define (run-last-command state)
 116   (let ((procedure (fluid-ref last-command)))
 117     (if procedure
 118         (procedure state)
 119         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            #f)))
 128
 129 (define last-command (make-fluid))
 130
 131 (define (user-warning . objects)
 132   (for-each (lambda (object)
 133               (display object))
 134             objects)
 135   (newline))
 136
 137 (define (user-error . objects)
 138   (apply throw 'debugger-user-error objects))
 139 \f
 140 ;;;; Command dispatch
 141
 142 (define (dispatch-command string table state port)
 143   (let ((value (command-table-value table string)))
 144     (if value
 145         (dispatch-command/value value state port)
 146         (user-error "Unknown command: " string))))
 147
 148 (define (dispatch-command/value value state port)
 149   (cond ((command? value)
 150          (dispatch-command/command value state port))
 151         ((command-table? value)
 152          (dispatch-command/table value state port))
 153         ((list? value)
 154          (dispatch-command/name value state port))
 155         (else
 156          (error "Unrecognized command-table value: " value))))
 157
 158 (define (dispatch-command/command command state port)
 159   (let ((procedure (command-procedure command))
 160         (arguments ((command-parser command) port)))
 161     (let ((procedure (lambda (state) (apply procedure state arguments))))
 162       (warn-about-extra-args port)
 163       (fluid-set! last-command procedure)
 164       (procedure state))))
 165
 166 (define (warn-about-extra-args port)
 167   ;; **** modify this to show the arguments.
 168   (let ((char (skip-whitespace port)))
 169     (cond ((eof-object? char) #f)
 170           ((char=? #\newline char) (read-char port))
 171           (else
 172            (user-warning "Extra arguments at end of line: "
 173                          (read-rest-of-line port))))))
 174
 175 (define (dispatch-command/table table state port)
 176   (let ((token (read-token port)))
 177     (if (or (eof-object? token)
 178             (not token))
 179         (user-error "Command name too short.")
 180         (dispatch-command token table state port))))
 181
 182 (define (dispatch-command/name name state port)
 183   (let ((value (lookup-command name)))
 184     (cond ((not value)
 185            (apply user-error "Unknown command name: " name))
 186           ((command-table? value)
 187            (apply user-error "Partial command name: " name))
 188           (else
 189            (dispatch-command/value value state port)))))
 190 \f
 191 ;;;; Command definition
 192
 193 (define (define-command name argument-template documentation procedure)
 194   (let ((name (canonicalize-command-name name)))
 195     (add-command name
 196                  (make-command name
 197                                (argument-template->parser argument-template)
 198                                documentation
 199                                procedure)
 200                  command-table)
 201     name))
 202
 203 (define (define-command-alias name1 name2)
 204   (let ((name1 (canonicalize-command-name name1)))
 205     (add-command name1 (canonicalize-command-name name2) command-table)
 206     name1))
 207 \f
 208 (define (argument-template->parser template)
 209   ;; Deliberately handles only cases that occur in "commands.scm".
 210   (cond ((eq? 'tokens template)
 211          (lambda (port)
 212            (let loop ((tokens '()))
 213              (let ((token (read-token port)))
 214                (if (or (eof-object? token)
 215                        (not token))
 216                    (list (reverse! tokens))
 217                    (loop (cons token tokens)))))))
 218         ((null? template)
 219          (lambda (port)
 220            '()))
 221         ((and (pair? template)
 222               (null? (cdr template))
 223               (eq? 'object (car template)))
 224          (lambda (port)
 225            (list (read port))))
 226         ((and (pair? template)
 227               (equal? ''optional (car template))
 228               (pair? (cdr template))
 229               (null? (cddr template)))
 230          (case (cadr template)
 231            ((token)
 232             (lambda (port)
 233               (let ((token (read-token port)))
 234                 (if (or (eof-object? token)
 235                         (not token))
 236                     (list #f)
 237                     (list token)))))
 238            ((exact-integer)
 239             (lambda (port)
 240               (list (parse-optional-exact-integer port))))
 241            ((exact-nonnegative-integer)
 242             (lambda (port)
 243               (list (parse-optional-exact-nonnegative-integer port))))
 244            ((object)
 245             (lambda (port)
 246               (list (parse-optional-object port))))
 247            (else
 248             (error "Malformed argument template: " template))))
 249         (else
 250          (error "Malformed argument template: " template))))
 251
 252 (define (parse-optional-exact-integer port)
 253   (let ((object (parse-optional-object port)))
 254     (if (or (not object)
 255             (and (integer? object)
 256                  (exact? object)))
 257         object
 258         (user-error "Argument not an exact integer: " object))))
 259
 260 (define (parse-optional-exact-nonnegative-integer port)
 261   (let ((object (parse-optional-object port)))
 262     (if (or (not object)
 263             (and (integer? object)
 264                  (exact? object)
 265                  (not (negative? object))))
 266         object
 267         (user-error "Argument not an exact non-negative integer: " object))))
 268
 269 (define (parse-optional-object port)
 270   (let ((terminator (skip-whitespace port)))
 271     (if (or (eof-object? terminator)
 272             (eq? #\newline terminator))
 273         #f
 274         (let ((object (read port)))
 275           (if (eof-object? object)
 276               #f
 277               object)))))
 278 \f
 279 ;;;; Command tables
 280
 281 (define (lookup-command name)
 282   (let loop ((table command-table) (strings name))
 283     (let ((value (command-table-value table (car strings))))
 284       (cond ((or (not value) (null? (cdr strings))) value)
 285             ((command-table? value) (loop value (cdr strings)))
 286             (else #f)))))
 287
 288 (define (command-table-value table string)
 289   (let ((entry (command-table-entry table string)))
 290     (and entry
 291          (caddr entry))))
 292
 293 (define (command-table-entry table string)
 294   (let loop ((entries (command-table-entries table)))
 295     (and (not (null? entries))
 296          (let ((entry (car entries)))
 297            (if (and (<= (cadr entry)
 298                         (string-length string)
 299                         (string-length (car entry)))
 300                     (= (string-length string)
 301                        (match-strings (car entry) string)))
 302                entry
 303                (loop (cdr entries)))))))
 304
 305 (define (match-strings s1 s2)
 306   (let ((n (min (string-length s1) (string-length s2))))
 307     (let loop ((i 0))
 308       (cond ((= i n) i)
 309             ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
 310             (else i)))))
 311
 312 (define (write-command-name name)
 313   (display (car name))
 314   (for-each (lambda (string)
 315               (write-char #\space)
 316               (display string))
 317             (cdr name)))
 318 \f
 319 (define (add-command name value table)
 320   (let loop ((strings name) (table table))
 321     (let ((entry
 322            (or (let loop ((entries (command-table-entries table)))
 323                  (and (not (null? entries))
 324                       (if (string=? (car strings) (caar entries))
 325                           (car entries)
 326                           (loop (cdr entries)))))
 327                (let ((entry (list (car strings) #f #f)))
 328                  (let ((entries
 329                         (let ((entries (command-table-entries table)))
 330                           (if (or (null? entries)
 331                                   (string<? (car strings) (caar entries)))
 332                               (cons entry entries)
 333                               (begin
 334                                 (let loop ((prev entries) (this (cdr entries)))
 335                                   (if (or (null? this)
 336                                           (string<? (car strings) (caar this)))
 337                                       (set-cdr! prev (cons entry this))
 338                                       (loop this (cdr this))))
 339                                 entries)))))
 340                    (compute-string-abbreviations! entries)
 341                    (set-command-table-entries! table entries))
 342                  entry))))
 343       (if (null? (cdr strings))
 344           (set-car! (cddr entry) value)
 345           (loop (cdr strings)
 346                 (if (command-table? (caddr entry))
 347                     (caddr entry)
 348                     (let ((table (make-command-table '())))
 349                       (set-car! (cddr entry) table)
 350                       table)))))))
 351
 352 (define (canonicalize-command-name name)
 353   (cond ((and (string? name)
 354               (not (string-null? name)))
 355          (list name))
 356         ((let loop ((name name))
 357            (and (pair? name)
 358                 (string? (car name))
 359                 (not (string-null? (car name)))
 360                 (or (null? (cdr name))
 361                     (loop (cdr name)))))
 362          name)
 363         (else
 364          (error "Illegal command name: " name))))
 365
 366 (define (compute-string-abbreviations! entries)
 367   (let loop ((entries entries) (index 0))
 368     (let ((groups '()))
 369       (for-each
 370        (lambda (entry)
 371          (let* ((char (string-ref (car entry) index))
 372                 (group (assv char groups)))
 373            (if group
 374                (set-cdr! group (cons entry (cdr group)))
 375                (set! groups
 376                      (cons (list char entry)
 377                            groups)))))
 378        entries)
 379       (for-each
 380        (lambda (group)
 381          (let ((index (+ index 1)))
 382            (if (null? (cddr group))
 383                (set-car! (cdadr group) index)
 384                (loop (let ((entry
 385                             (let loop ((entries (cdr group)))
 386                               (and (not (null? entries))
 387                                    (if (= index (string-length (caar entries)))
 388                                        (car entries)
 389                                        (loop (cdr entries)))))))
 390                        (if entry
 391                            (begin
 392                              (set-car! (cdr entry) index)
 393                              (delq entry (cdr group)))
 394                            (cdr group)))
 395                      index))))
 396        groups))))
 397 \f
 398 ;;;; Data structures
 399
 400 (define command-table-rtd (make-record-type "command-table" '(entries)))
 401 (define make-command-table (record-constructor command-table-rtd '(entries)))
 402 (define command-table? (record-predicate command-table-rtd))
 403 (define command-table-entries (record-accessor command-table-rtd 'entries))
 404 (define set-command-table-entries!
 405   (record-modifier command-table-rtd 'entries))
 406
 407 (define command-rtd
 408   (make-record-type "command"
 409                     '(name parser documentation procedure)))
 410
 411 (define make-command
 412   (record-constructor command-rtd
 413                       '(name parser documentation procedure)))
 414
 415 (define command? (record-predicate command-rtd))
 416 (define command-name (record-accessor command-rtd 'name))
 417 (define command-parser (record-accessor command-rtd 'parser))
 418 (define command-documentation (record-accessor command-rtd 'documentation))
 419 (define command-procedure (record-accessor command-rtd 'procedure))
 420
 421 (define state-rtd (make-record-type "debugger-state" '(stack index)))
 422 (define state? (record-predicate state-rtd))
 423 (define make-state (record-constructor state-rtd '(stack index)))
 424 (define state-stack (record-accessor state-rtd 'stack))
 425 (define state-index (record-accessor state-rtd 'index))
 426
 427 (define (new-state-index state index)
 428   (make-state (state-stack state) index))
 429 \f
 430 ;;;; Character parsing
 431
 432 (define (read-token port)
 433   (letrec
 434       ((loop
 435         (lambda (chars)
 436           (let ((char (peek-char port)))
 437             (cond ((eof-object? char)
 438                    (do-eof char chars))
 439                   ((char=? #\newline char)
 440                    (do-eot chars))
 441                   ((char-whitespace? char)
 442                    (do-eot chars))
 443                   ((char=? #\# char)
 444                    (read-char port)
 445                    (let ((terminator (skip-comment port)))
 446                      (if (eof-object? char)
 447                          (do-eof char chars)
 448                          (do-eot chars))))
 449                   (else
 450                    (read-char port)
 451                    (loop (cons char chars)))))))
 452        (do-eof
 453         (lambda (eof chars)
 454           (if (null? chars)
 455               eof
 456               (do-eot chars))))
 457        (do-eot
 458         (lambda (chars)
 459           (if (null? chars)
 460               #f
 461               (list->string (reverse! chars))))))
 462     (skip-whitespace port)
 463     (loop '())))
 464
 465 (define (skip-whitespace port)
 466   (let ((char (peek-char port)))
 467     (cond ((or (eof-object? char)
 468                (char=? #\newline char))
 469            char)
 470           ((char-whitespace? char)
 471            (read-char port)
 472            (skip-whitespace port))
 473           ((char=? #\# char)
 474            (read-char port)
 475            (skip-comment port))
 476           (else char))))
 477
 478 (define (skip-comment port)
 479   (let ((char (peek-char port)))
 480     (if (or (eof-object? char)
 481             (char=? #\newline char))
 482         char
 483         (begin
 484           (read-char port)
 485           (skip-comment port)))))
 486
 487 (define (read-rest-of-line port)
 488   (let loop ((chars '()))
 489     (let ((char (read-char port)))
 490       (if (or (eof-object? char)
 491               (char=? #\newline char))
 492           (list->string (reverse! chars))
 493           (loop (cons char chars))))))
 494
 495 (define (discard-rest-of-line port)
 496   (let loop ()
 497     (if (not (let ((char (read-char port)))
 498                (or (eof-object? char)
 499                    (char=? #\newline char))))
 500         (loop))))
 501 \f
 502 ;;;; Commands
 503
 504 (define command-table (make-command-table '()))
 505
 506 (define-command "help" 'tokens
 507   "Type \"help\" followed by a command name for full documentation."
 508   (lambda (state tokens)
 509     (let loop ((name (if (null? tokens) '("help") tokens)))
 510       (let ((value (lookup-command name)))
 511         (cond ((not value)
 512                (write-command-name name)
 513                (display " is not a known command name.")
 514                (newline))
 515               ((command? value)
 516                (display (command-documentation value))
 517                (newline)
 518                (if (equal? '("help") (command-name value))
 519                    (begin
 520                      (display "Available commands are:")
 521                      (newline)
 522                      (for-each (lambda (entry)
 523                                  (if (not (list? (caddr entry)))
 524                                      (begin
 525                                        (display "  ")
 526                                        (display (car entry))
 527                                        (newline))))
 528                                (command-table-entries command-table)))))
 529               ((command-table? value)
 530                (display "The \"")
 531                (write-command-name name)
 532                (display "\" command requires a subcommand.")
 533                (newline)
 534                (display "Available subcommands are:")
 535                (newline)
 536                (for-each (lambda (entry)
 537                            (if (not (list? (caddr entry)))
 538                                (begin
 539                                  (display "  ")
 540                                  (write-command-name name)
 541                                  (write-char #\space)
 542                                  (display (car entry))
 543                                  (newline))))
 544                          (command-table-entries value)))
 545               ((list? value)
 546                (loop value))
 547               (else
 548                (error "Unknown value from lookup-command:" value)))))
 549     state))
 550
 551 (define-command "frame" '('optional exact-nonnegative-integer)
 552   "Select and print a stack frame.
 553 With no argument, print the selected stack frame.  (See also \"info frame\").
 554 An argument specifies the frame to select; it must be a stack-frame number."
 555   (lambda (state n)
 556     (let ((state (if n (select-frame-absolute state n) state)))
 557       (write-state-short state)
 558       state)))
 559
 560 (define-command "position" '()
 561   "Display the position of the current expression."
 562   (lambda (state)
 563     (let* ((frame (stack-ref (state-stack state) (state-index state)))
 564            (source (frame-source frame)))
 565       (if (not source)
 566           (display "No source available for this frame.")
 567           (let ((position (source-position source)))
 568             (if (not position)
 569                 (display "No position information available for this frame.")
 570                 (display-position position)))))
 571     (newline)
 572     state))
 573
 574 (define-command "up" '('optional exact-integer)
 575   "Move N frames up the stack.  For positive numbers N, this advances
 576 toward the outermost frame, to higher frame numbers, to frames
 577 that have existed longer.  N defaults to one."
 578   (lambda (state n)
 579     (let ((state (select-frame-relative state (or n 1))))
 580       (write-state-short state)
 581       state)))
 582
 583 (define-command "down" '('optional exact-integer)
 584   "Move N frames down the stack.  For positive numbers N, this
 585 advances toward the innermost frame, to lower frame numbers, to
 586 frames that were created more recently.  N defaults to one."
 587   (lambda (state n)
 588     (let ((state (select-frame-relative state (- (or n 1)))))
 589       (write-state-short state)
 590       state)))
 591 \f
 592 (define (eval-handler key . args)
 593   (let ((stack (make-stack #t eval-handler)))
 594     (if (= (length args) 4)
 595         (apply display-error stack (current-error-port) args)
 596         ;; We want display-error to be the "final common pathway"
 597         (catch #t
 598                (lambda ()
 599                  (apply bad-throw key args))
 600                (lambda (key . args)
 601                  (apply display-error stack (current-error-port) args)))))
 602   (throw 'continue))
 603
 604 (define-command "evaluate" '(object)
 605   "Evaluate an expression.
 606 The expression must appear on the same line as the command,
 607 however it may be continued over multiple lines."
 608   (lambda (state expression)
 609     (let ((source (frame-source (stack-ref (state-stack state)
 610                                            (state-index state)))))
 611       (if (not source)
 612           (display "No environment for this frame.\n")
 613           (catch 'continue
 614                  (lambda ()
 615                    (lazy-catch #t
 616                                (lambda ()
 617                                  (let* ((env (memoized-environment source))
 618                                         (value (local-eval expression env)))
 619                                    (display ";value: ")
 620                                    (write value)
 621                                    (newline)))
 622                                eval-handler))
 623                  (lambda args args)))
 624       state)))
 625
 626 (define-command "backtrace" '('optional exact-integer)
 627   "Print backtrace of all stack frames, or innermost COUNT frames.
 628 With a negative argument, print outermost -COUNT frames.
 629 If the number of frames aren't explicitly given, the debug option
 630 `depth' determines the maximum number of frames printed."
 631   (lambda (state n-frames)
 632     (let ((stack (state-stack state)))
 633       ;; Kludge around lack of call-with-values.
 634       (let ((values
 635              (lambda (start end)
 636                ;;(do ((index start (+ index 1)))
 637                ;;    ((= index end))
 638                ;;(write-state-short* stack index))
 639                ;;
 640                ;; Use builtin backtrace instead:
 641                (display-backtrace stack
 642                                   (current-output-port)
 643                                   (if (memq 'backwards (debug-options))
 644                                       start
 645                                       (- end 1))
 646                                   (- end start))
 647                )))
 648         (let ((end (stack-length stack)))
 649           (cond ((not n-frames) ;(>= (abs n-frames) end))
 650                  (values 0 (min end (cadr (memq 'depth (debug-options))))))
 651                 ((>= n-frames 0)
 652                  (values 0 n-frames))
 653                 (else
 654                  (values (+ end n-frames) end))))))
 655     state))
 656
 657 (define-command "quit" '()
 658   "Exit the debugger."
 659   (lambda (state)
 660     (throw 'exit-debugger)))
 661
 662 (define-command '("info" "frame") '()
 663   "All about selected stack frame."
 664   (lambda (state)
 665     (write-state-long state)
 666     state))
 667
 668 (define-command '("info" "args") '()
 669   "Argument variables of current stack frame."
 670   (lambda (state)
 671     (let ((index (state-index state)))
 672       (let ((frame (stack-ref (state-stack state) index)))
 673         (write-frame-index-long frame)
 674         (write-frame-args-long frame)))
 675     state))
 676
 677 (define-command-alias "f" "frame")
 678 (define-command-alias '("info" "f") '("info" "frame"))
 679 (define-command-alias "bt" "backtrace")
 680 (define-command-alias "where" "backtrace")
 681 (define-command-alias "p" "evaluate")
 682 (define-command-alias '("info" "stack") "backtrace")
 683 \f
 684 ;;;; Command Support
 685
 686 (define (select-frame-absolute state number)
 687   (new-state-index state
 688                    (frame-number->index
 689                     (let ((end (stack-length (state-stack state))))
 690                       (if (>= number end)
 691                           (- end 1)
 692                           number))
 693                     (state-stack state))))
 694
 695 (define (select-frame-relative state delta)
 696   (new-state-index state
 697                    (let ((index (+ (state-index state) delta))
 698                          (end (stack-length (state-stack state))))
 699                      (cond ((< index 0) 0)
 700                            ((>= index end) (- end 1))
 701                            (else index)))))
 702
 703 (define (write-state-short state)
 704   (display "Frame ")
 705   (write-state-short* (state-stack state) (state-index state)))
 706
 707 (define (write-state-short* stack index)
 708   (write-frame-index-short stack index)
 709   (write-char #\space)
 710   (write-frame-short (stack-ref stack index))
 711   (newline))
 712
 713 (define (write-frame-index-short stack index)
 714   (let ((s (number->string (frame-number (stack-ref stack index)))))
 715     (display s)
 716     (write-char #\:)
 717     (write-chars #\space (- 4 (string-length s)))))
 718
 719 (define (write-frame-short frame)
 720   (if (frame-procedure? frame)
 721       (write-frame-short/application frame)
 722       (write-frame-short/expression frame)))
 723
 724 (define (write-frame-short/application frame)
 725   (write-char #\[)
 726   (write (let ((procedure (frame-procedure frame)))
 727            (or (and (procedure? procedure)
 728                     (procedure-name procedure))
 729                procedure)))
 730   (if (frame-evaluating-args? frame)
 731       (display " ...")
 732       (begin
 733         (for-each (lambda (argument)
 734                     (write-char #\space)
 735                     (write argument))
 736                   (frame-arguments frame))
 737         (write-char #\]))))
 738
 739 ;;; Use builtin function instead:
 740 (set! write-frame-short/application
 741       (lambda (frame)
 742         (display-application frame (current-output-port) 12)))
 743
 744 (define (write-frame-short/expression frame)
 745   (write (let* ((source (frame-source frame))
 746                 (copy (source-property source 'copy)))
 747            (if (pair? copy)
 748                copy
 749                (unmemoize source)))))
 750 \f
 751 (define (write-state-long state)
 752   (let ((index (state-index state)))
 753     (let ((frame (stack-ref (state-stack state) index)))
 754       (write-frame-index-long frame)
 755       (write-frame-long frame))))
 756
 757 (define (write-frame-index-long frame)
 758   (display "Stack frame: ")
 759   (write (frame-number frame))
 760   (if (frame-real? frame)
 761       (display " (real)"))
 762   (newline))
 763
 764 (define (write-frame-long frame)
 765   (if (frame-procedure? frame)
 766       (write-frame-long/application frame)
 767       (write-frame-long/expression frame)))
 768
 769 (define (write-frame-long/application frame)
 770   (display "This frame is an application.")
 771   (newline)
 772   (if (frame-source frame)
 773       (begin
 774         (display "The corresponding expression is:")
 775         (newline)
 776         (display-source frame)
 777         (newline)))
 778   (display "The procedure being applied is: ")
 779   (write (let ((procedure (frame-procedure frame)))
 780            (or (and (procedure? procedure)
 781                     (procedure-name procedure))
 782                procedure)))
 783   (newline)
 784   (display "The procedure's arguments are")
 785   (if (frame-evaluating-args? frame)
 786       (display " being evaluated.")
 787       (begin
 788         (display ": ")
 789         (write (frame-arguments frame))))
 790   (newline))
 791
 792 (define (display-source frame)
 793   (let* ((source (frame-source frame))
 794          (copy (source-property source 'copy)))
 795     (cond ((source-position source)
 796            => (lambda (p) (display-position p) (display ":\n"))))
 797     (display "  ")
 798     (write (or copy (unmemoize source)))))
 799
 800 (define (source-position source)
 801   (let ((fname (source-property source 'filename))
 802         (line (source-property source 'line))
 803         (column (source-property source 'column)))
 804     (and fname
 805          (list fname line column))))
 806
 807 (define (display-position pos)
 808   (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))
 809
 810 (define (write-frame-long/expression frame)
 811   (display "This frame is an evaluation.")
 812   (newline)
 813   (display "The expression being evaluated is:")
 814   (newline)
 815   (display-source frame)
 816   (newline))
 817
 818 (define (write-frame-args-long frame)
 819   (if (frame-procedure? frame)
 820       (let ((arguments (frame-arguments frame)))
 821         (let ((n (length arguments)))
 822           (display "This frame has ")
 823           (write n)
 824           (display " argument")
 825           (if (not (= n 1))
 826               (display "s"))
 827           (write-char (if (null? arguments) #\. #\:))
 828           (newline))
 829         (for-each (lambda (argument)
 830                     (display "  ")
 831                     (write argument)
 832                     (newline))
 833                   arguments))
 834       (begin
 835         (display "This frame is an evaluation frame; it has no arguments.")
 836         (newline))))
 837
 838 (define (write-chars char n)
 839   (do ((i 0 (+ i 1)))
 840       ((>= i n))
 841     (write-char char)))