;;;
(define *command-table*
- '((help (help h) (show s) (apropos a) (describe d))
+ '((help (help h) (show) (apropos a) (describe d))
(module (module m) (import use) (load l) (binding b))
(language (language L))
(compile (compile c) (compile-file cc)
(debug (backtrace bt) (up) (down) (frame fr)
(procedure proc) (locals) (error-message error)
(break br bp) (break-at-source break-at bs)
+ (step s) (step-instruction si)
+ (next n) (next-instruction ni)
(finish)
(tracepoint tp)
(traps) (delete del) (disable) (enable)
(add-ephemeral-trap-at-frame-finish! cur handler)
(throw 'quit)))
+(define (repl-next-resumer msg)
+ ;; Capture the dynamic environment with this prompt thing. The
+ ;; result is a procedure that takes a frame.
+ (% (let ((stack (abort
+ (lambda (k)
+ ;; Call frame->stack-vector before reinstating the
+ ;; continuation, so that we catch the %stacks fluid
+ ;; at the time of capture.
+ (lambda (frame)
+ (k (frame->stack-vector frame)))))))
+ (format #t "~a~%" msg)
+ ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
+ #:debug (make-debug stack 0 msg)))))
+
+(define-stack-command (step repl)
+ "step
+Step until control reaches a different source location.
+
+Step until control reaches a different source location."
+ (let ((msg (format #f "Step into ~a" cur)))
+ (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+ #:into? #t #:instruction? #f)
+ (throw 'quit)))
+
+(define-stack-command (step-instruction repl)
+ "step-instruction
+Step until control reaches a different instruction.
+
+Step until control reaches a different VM instruction."
+ (let ((msg (format #f "Step into ~a" cur)))
+ (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+ #:into? #t #:instruction? #t)
+ (throw 'quit)))
+
+(define-stack-command (next repl)
+ "next
+Step until control reaches a different source location in the current frame.
+
+Step until control reaches a different source location in the current frame."
+ (let ((msg (format #f "Step into ~a" cur)))
+ (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+ #:into? #f #:instruction? #f)
+ (throw 'quit)))
+
+(define-stack-command (step-instruction repl)
+ "next-instruction
+Step until control reaches a different instruction in the current frame.
+
+Step until control reaches a different VM instruction in the current frame."
+ (let ((msg (format #f "Step into ~a" cur)))
+ (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+ #:into? #f #:instruction? #t)
+ (throw 'quit)))
+
(define-meta-command (tracepoint repl (form))
"tracepoint PROCEDURE
Add a tracepoint to PROCEDURE.
#:use-module (system vm vm)
#:use-module (system vm traps)
#:use-module (system vm trace)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
#:export (list-traps
trap-enabled?
trap-name
add-trap-at-procedure-call!
add-trace-at-procedure-call!
add-trap-at-source-location!
- add-ephemeral-trap-at-frame-finish!))
+ add-ephemeral-trap-at-frame-finish!
+ add-ephemeral-stepping-trap!))
(define %default-trap-handler (make-fluid))
idx #t trap
(format #f "Return from ~a" frame)))))
+(define (source-string source)
+ (if source
+ (format #f "~a:~a:~a" (or (source:file source) "unknown file")
+ (source:line-for-user source) (source:column source))
+ "unknown source location"))
+
+(define* (add-ephemeral-stepping-trap! frame handler
+ #:optional (trap-state
+ (the-trap-state))
+ #:key (into? #t) (instruction? #f))
+ (define (wrap-predicate-according-to-into predicate)
+ (if into?
+ predicate
+ (let ((fp (frame-address frame)))
+ (lambda (f)
+ (and (<= (frame-address f) fp)
+ (predicate f))))))
+
+ (let* ((source (frame-source frame))
+ (idx (next-ephemeral-index! trap-state))
+ (trap (trap-matching-instructions
+ (wrap-predicate-according-to-into
+ (if instruction?
+ (lambda (f) #t)
+ (lambda (f) (not (equal? (frame-source f) source)))))
+ (ephemeral-handler-for-index trap-state idx handler))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (if instruction?
+ (if into?
+ "Step to different instruction"
+ (format #f "Step to different instruction in ~a" frame))
+ (if into?
+ (format #f "Step into ~a" (source-string source))
+ (format #f "Step out of ~a" (source-string source))))))))
+
(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
(let* ((idx (next-index! trap-state)))
(add-trap-wrapper!
trap-in-dynamic-extent
trap-calls-in-dynamic-extent
trap-instructions-in-dynamic-extent
- trap-calls-to-procedure))
+ trap-calls-to-procedure
+ trap-matching-instructions))
(define-syntax arg-check
(syntax-rules ()
(with-pending-finish-disablers
(trap-at-procedure-call proc apply-hook #:vm vm))))
+
+;; Trap when the source location changes.
+;;
+(define* (trap-matching-instructions frame-pred handler
+ #:key (vm (the-vm)))
+ (arg-check frame-pred procedure?)
+ (arg-check handler procedure?)
+ (let ()
+ (define (next-hook frame)
+ (if (frame-pred frame)
+ (handler frame)))
+
+ (new-enabled-trap
+ vm #f
+ (lambda (frame)
+ (add-hook! (vm-next-hook vm) next-hook))
+ (lambda (frame)
+ (remove-hook! (vm-next-hook vm) next-hook)))))