ice-9/debugger.scm

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