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