;;; along with this software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
+;;;
+;;; As a special exception, the Free Software Foundation gives permission
+;;; for additional uses of the text contained in its release of GUILE.
+;;;
+;;; The exception is that, if you link the GUILE library with other files
+;;; to produce an executable, this does not by itself cause the
+;;; resulting executable to be covered by the GNU General Public License.
+;;; Your use of that executable is in no way restricted on account of
+;;; linking the GUILE library code into it.
+;;;
+;;; This exception does not however invalidate any other reasons why
+;;; the executable file might be covered by the GNU General Public License.
+;;;
+;;; This exception applies only to the code released by the
+;;; Free Software Foundation under the name GUILE. If you copy
+;;; code from other Free Software Foundation releases into a copy of
+;;; GUILE, as the General Public License permits, the exception does
+;;; not apply to the code that you add in this way. To avoid misleading
+;;; anyone as to the status of such modified files, you must delete
+;;; this exception notice from them.
+;;;
+;;; If you write modifications of your own for GUILE, it is your choice
+;;; whether to permit this exception to apply to your modifications.
+;;; If you do not wish that, delete this exception notice.
(define-module (ice-9 debugger)
- :use-module (ice-9 readline))
+ :use-module (ice-9 debug)
+ :use-module (ice-9 format)
+ :no-backtrace
+ )
+
+(if (memq 'readline *features*)
+ (define-module (ice-9 debugger)
+ :use-module (ice-9 readline)))
+
\f
+(define debugger-prompt "debug> ")
+
(define-public (debug)
(let ((stack (fluid-ref the-last-stack)))
(if stack
(read-and-dispatch-commands state (current-input-port)))
(display "Nothing to debug.\n"))))
+(define (debugger-handler key . args)
+ (case key
+ ((exit-debugger) #f)
+ ((signal)
+ ;; Restore stack
+ (fluid-set! the-last-stack (fluid-ref before-signal-stack))
+ (apply display-error #f (current-error-port) args))
+ (else
+ (display "Internal debugger error:\n")
+ (save-stack debugger-handler)
+ (apply throw key args)))
+ (throw 'exit-debugger)) ;Pop the stack
+
(define (read-and-dispatch-commands state port)
(catch 'exit-debugger
- (lambda ()
- (with-fluids ((last-command #f))
- (let loop ((state state))
- (loop (read-and-dispatch-command state port)))))
- (lambda arguments
- (set-readline-prompt! scm-repl-prompt)
- 'done)))
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (with-fluids ((last-command #f))
+ (let loop ((state state))
+ (loop (read-and-dispatch-command state port)))))
+ debugger-handler))
+ (lambda args
+ *unspecified*)))
(define (read-and-dispatch-command state port)
- (set-readline-prompt! "debug> ")
+ (if (using-readline?)
+ (set-readline-prompt! debugger-prompt)
+ (display debugger-prompt))
+ (force-output) ;This should not be necessary...
(let ((token (read-token port)))
(cond ((eof-object? token)
(throw 'exit-debugger))
(discard-rest-of-line port)
(catch-user-errors port (lambda () (run-last-command state))))
(else
- (catch-user-errors port
- (lambda ()
- (dispatch-command token command-table state port)))))))
+ (or (catch-user-errors port
+ (lambda ()
+ (dispatch-command token command-table state port)))
+ state)))))
(define (run-last-command state)
(let ((procedure (fluid-ref last-command)))
thunk
(lambda (key . objects)
(apply user-warning objects)
- (discard-rest-of-line port))))
+ (discard-rest-of-line port)
+ #f)))
(define last-command (make-fluid))
(write-state-short state)
state)))
+(define-command "position" '()
+ "Display the position of the current expression."
+ (lambda (state)
+ (let* ((frame (stack-ref (state-stack state) (state-index state)))
+ (source (frame-source frame)))
+ (if (not source)
+ (display "No source available for this frame.")
+ (let ((position (source-position source)))
+ (if (not position)
+ (display "No position information available for this frame.")
+ (display-position position)))))
+ (newline)
+ state))
+
(define-command "up" '('optional exact-integer)
"Move N frames up the stack. For positive numbers N, this advances
toward the outermost frame, to higher frame numbers, to frames
(write-state-short state)
state)))
\f
+(define (eval-handler key . args)
+ (let ((stack (make-stack #t eval-handler)))
+ (if (= (length args) 4)
+ (apply display-error stack (current-error-port) args)
+ ;; We want display-error to be the "final common pathway"
+ (catch #t
+ (lambda ()
+ (apply bad-throw key args))
+ (lambda (key . args)
+ (apply display-error stack (current-error-port) args)))))
+ (throw 'continue))
+
(define-command "evaluate" '(object)
"Evaluate an expression.
The expression must appear on the same line as the command,
however it may be continued over multiple lines."
(lambda (state expression)
- (let ((value (eval expression)))
- (display ";value: ")
- (write value))
- state))
+ (let ((source (frame-source (stack-ref (state-stack state)
+ (state-index state)))))
+ (if (not source)
+ (display "No environment for this frame.\n")
+ (catch 'continue
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (let* ((env (memoized-environment source))
+ (value (local-eval expression env)))
+ (display ";value: ")
+ (write value)
+ (newline)))
+ eval-handler))
+ (lambda args args)))
+ state)))
(define-command "backtrace" '('optional exact-integer)
"Print backtrace of all stack frames, or innermost COUNT frames.
-With a negative argument, print outermost -COUNT frames."
+With a negative argument, print outermost -COUNT frames.
+If the number of frames aren't explicitly given, the debug option
+`depth' determines the maximum number of frames printed."
(lambda (state n-frames)
(let ((stack (state-stack state)))
;; Kludge around lack of call-with-values.
(let ((values
(lambda (start end)
- (do ((index start (+ index 1)))
- ((= index end))
- (write-state-short* stack index)))))
+ ;;(do ((index start (+ index 1)))
+ ;; ((= index end))
+ ;;(write-state-short* stack index))
+ ;;
+ ;; Use builtin backtrace instead:
+ (display-backtrace stack
+ (current-output-port)
+ (if (memq 'backwards (debug-options))
+ start
+ (- end 1))
+ (- end start))
+ )))
(let ((end (stack-length stack)))
- (cond ((or (not n-frames) (>= (abs n-frames) end))
- (values 0 end))
+ (cond ((not n-frames) ;(>= (abs n-frames) end))
+ (values 0 (min end (cadr (memq 'depth (debug-options))))))
((>= n-frames 0)
(values 0 n-frames))
(else
(lambda (state)
(let ((index (state-index state)))
(let ((frame (stack-ref (state-stack state) index)))
- (write-frame-index-long frame index)
+ (write-frame-index-long frame)
(write-frame-args-long frame)))
state))
(define-command-alias '("info" "f") '("info" "frame"))
(define-command-alias "bt" "backtrace")
(define-command-alias "where" "backtrace")
+(define-command-alias "p" "evaluate")
(define-command-alias '("info" "stack") "backtrace")
\f
;;;; Command Support
-(define (select-frame-absolute state index)
+(define (select-frame-absolute state number)
(new-state-index state
- (let ((end (stack-length (state-stack state))))
- (if (>= index end)
- (- end 1)
- index))))
+ (frame-number->index
+ (let ((end (stack-length (state-stack state))))
+ (if (>= number end)
+ (- end 1)
+ number))
+ (state-stack state))))
(define (select-frame-relative state delta)
(new-state-index state
(write-state-short* (state-stack state) (state-index state)))
(define (write-state-short* stack index)
- (write-frame-index-short index)
+ (write-frame-index-short stack index)
(write-char #\space)
(write-frame-short (stack-ref stack index))
(newline))
-(define (write-frame-index-short index)
- (let ((s (number->string index)))
+(define (write-frame-index-short stack index)
+ (let ((s (number->string (frame-number (stack-ref stack index)))))
(display s)
(write-char #\:)
(write-chars #\space (- 4 (string-length s)))))
(write-char #\]))))
;;; Use builtin function instead:
-(set! write-frame-short/application display-application)
+(set! write-frame-short/application
+ (lambda (frame)
+ (display-application frame (current-output-port) 12)))
(define (write-frame-short/expression frame)
(write (let* ((source (frame-source frame))
(define (write-state-long state)
(let ((index (state-index state)))
(let ((frame (stack-ref (state-stack state) index)))
- (write-frame-index-long frame index)
+ (write-frame-index-long frame)
(write-frame-long frame))))
-(define (write-frame-index-long frame index)
+(define (write-frame-index-long frame)
(display "Stack frame: ")
- (write index)
+ (write (frame-number frame))
(if (frame-real? frame)
(display " (real)"))
(newline))
(define (write-frame-long/application frame)
(display "This frame is an application.")
(newline)
+ (if (frame-source frame)
+ (begin
+ (display "The corresponding expression is:")
+ (newline)
+ (display-source frame)
+ (newline)))
(display "The procedure being applied is: ")
(write (let ((procedure (frame-procedure frame)))
(or (and (procedure? procedure)
(write (frame-arguments frame))))
(newline))
+(define (display-source frame)
+ (let* ((source (frame-source frame))
+ (copy (source-property source 'copy)))
+ (cond ((source-position source)
+ => (lambda (p) (display-position p) (display ":\n"))))
+ (display " ")
+ (write (or copy (unmemoize source)))))
+
+(define (source-position source)
+ (let ((fname (source-property source 'filename))
+ (line (source-property source 'line))
+ (column (source-property source 'column)))
+ (and fname
+ (list fname line column))))
+
+(define (display-position pos)
+ (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))
+
(define (write-frame-long/expression frame)
(display "This frame is an evaluation.")
(newline)
(display "The expression being evaluated is:")
(newline)
- (display " ")
- (write (let* ((source (frame-source frame))
- (copy (source-property source 'copy)))
- (if (pair? copy)
- copy
- (unmemoize source))))
+ (display-source frame)
(newline))
(define (write-frame-args-long frame)
HCoop / bpt / guile.git / blobdiff