mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
integrate the debugger into the repl
* module/system/repl/debug.scm: New file, defines a data type to hold state for a debugger stack, and some helper procedures to print the stack or print a frame. Most pieces are from (system vm debug). * module/system/repl/error-handling.scm: New file, implements call-with-error-handling and with-error-handling, and instead of going into a debugger, we go into a recursive repl that happens to have debugging information. Will be removing the old debugger from (system vm debug) shortly. * module/Makefile.am (SYSTEM_SOURCES): Add error-handling and debug scm files. * module/system/repl/repl.scm (prompting-meta-read): Better error handling -- we don't want to go into a debugger when reading a command. (start-repl): Add #:debug keyword argument, and just dispatch to run-repl. (run-repl): New function, with the guts of the old start-repl. Added a prompt, to which a throw to 'quit will abort. * module/system/repl/common.scm (repl-prepare-eval-thunk): New helper. In the future we will use this to not enter the debugger on errors that happen at compile time. (repl-eval): Use repl-prepare-eval-thunk. (repl-print): Run the before-print-hook when printing a value. * module/system/repl/command.scm (*command-table*): Move `option' to the `system' group. Move `trace' to the `profile' group. Add `debug' and `inspect' groups. (command-abbrevs): Rename from command-abbrev, and allow multiple abbreviations. (display-group): Fix the case where abbrev? was #f. (display-summary): Fix alignment of the command and abbreviations. Allow multiple abbreviations. (read-command): Rename from read-datum, and have better error handling. (meta-command): Better error handling. (define-meta-command): Better error handling. (help, show, import, compile, disassemble, time, profile, trace): Fix docstrings and error messages. (define-stack-command): New helper, for commands that operate on a saved stack. (backtrace, up, down, frame, procedure, locals): New debugger commands, in the REPL now. (inspect, pretty-print): New "inspect" commands.
This commit is contained in:
Andy Wingo
parent
ddfb5e2bb0
commit
33df2ec719
6 changed files with 619 additions and 121 deletions
|
|
@ -319,9 +319,11 @@ SYSTEM_SOURCES = \
|
|||
system/vm/vm.scm \
|
||||
system/foreign.scm \
|
||||
system/xref.scm \
|
||||
system/repl/repl.scm \
|
||||
system/repl/debug.scm \
|
||||
system/repl/error-handling.scm \
|
||||
system/repl/common.scm \
|
||||
system/repl/command.scm
|
||||
system/repl/command.scm \
|
||||
system/repl/repl.scm
|
||||
|
||||
LIB_SOURCES = \
|
||||
statprof.scm \
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@
|
|||
#:use-module (system base pmatch)
|
||||
#:use-module (system base compile)
|
||||
#:use-module (system repl common)
|
||||
#:use-module (system repl debug)
|
||||
#:use-module (system vm objcode)
|
||||
#:use-module (system vm program)
|
||||
#:use-module (system vm vm)
|
||||
|
|
@ -35,6 +36,9 @@
|
|||
#:use-module (ice-9 documentation)
|
||||
#:use-module (ice-9 and-let-star)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 control)
|
||||
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
|
||||
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
|
||||
#:use-module (statprof)
|
||||
#:export (meta-command))
|
||||
|
||||
|
|
@ -44,14 +48,17 @@
|
|||
;;;
|
||||
|
||||
(define *command-table*
|
||||
'((help (help h) (show s) (apropos a) (describe d) (option o) (quit q))
|
||||
(module (module m) (import i) (load l) (binding b))
|
||||
'((help (help h) (show s) (apropos a) (describe d))
|
||||
(module (module m) (import use) (load l) (binding b))
|
||||
(language (language L))
|
||||
(compile (compile c) (compile-file cc)
|
||||
(disassemble x) (disassemble-file xx))
|
||||
(profile (time t) (profile pr))
|
||||
(debug (trace tr))
|
||||
(system (gc) (statistics stat))))
|
||||
(profile (time t) (profile pr) (trace tr))
|
||||
(debug (backtrace bt) (up) (down) (frame fr)
|
||||
(procedure proc) (locals))
|
||||
(inspect (inspect i) (pretty-print pp))
|
||||
(system (gc) (statistics stat) (option o)
|
||||
(quit q continue cont))))
|
||||
|
||||
(define *show-table*
|
||||
'((show (warranty w) (copying c) (version v))))
|
||||
|
|
@ -61,7 +68,7 @@
|
|||
|
||||
(define *command-module* (current-module))
|
||||
(define (command-name c) (car c))
|
||||
(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
|
||||
(define (command-abbrevs c) (cdr c))
|
||||
(define (command-procedure c) (module-ref *command-module* (command-name c)))
|
||||
(define (command-doc c) (procedure-documentation (command-procedure c)))
|
||||
|
||||
|
|
@ -88,10 +95,10 @@
|
|||
(else (loop groups (cdr commands))))))
|
||||
|
||||
(define* (display-group group #:optional (abbrev? #t))
|
||||
(format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
|
||||
(format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
|
||||
(for-each (lambda (c)
|
||||
(display-summary (command-usage c)
|
||||
(and abbrev? (command-abbrev c))
|
||||
(if abbrev? (command-abbrevs c) '())
|
||||
(command-summary c)))
|
||||
(group-commands group))
|
||||
(newline))
|
||||
|
|
@ -101,12 +108,37 @@
|
|||
(display (command-doc command))
|
||||
(newline))
|
||||
|
||||
(define (display-summary usage abbrev summary)
|
||||
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
|
||||
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
|
||||
(define (display-summary usage abbrevs summary)
|
||||
(let* ((usage-len (string-length usage))
|
||||
(abbrevs (if (pair? abbrevs)
|
||||
(format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
|
||||
""))
|
||||
(abbrevs-len (string-length abbrevs)))
|
||||
(format #t " ,~A~A~A - ~A\n"
|
||||
usage
|
||||
(cond
|
||||
((> abbrevs-len 32)
|
||||
(error "abbrevs too long" abbrevs))
|
||||
((> (+ usage-len abbrevs-len) 32)
|
||||
(format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
|
||||
(else
|
||||
(format #f "~v_" (- 32 abbrevs-len usage-len))))
|
||||
abbrevs
|
||||
summary)))
|
||||
|
||||
(define (read-datum repl)
|
||||
(read (repl-inport repl)))
|
||||
(define (read-command repl)
|
||||
(catch #t
|
||||
(lambda () (read (pk (repl-inport repl))))
|
||||
(lambda (key . args)
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(format #t "Throw to key `~a' while reading command:\n" key)
|
||||
(display-error #f (current-output-port) subr msg args rest))
|
||||
(else
|
||||
(format #t "Throw to key `~a' with args `~s' while reading command.\n"
|
||||
key args)))
|
||||
(force-output)
|
||||
*unspecified*)))
|
||||
|
||||
(define read-line
|
||||
(let ((orig-read-line read-line))
|
||||
|
|
@ -114,34 +146,57 @@
|
|||
(orig-read-line (repl-inport repl)))))
|
||||
|
||||
(define (meta-command repl)
|
||||
(let ((command (read-datum repl)))
|
||||
(if (not (symbol? command))
|
||||
(user-error "Meta-command not a symbol: ~s" command))
|
||||
(let ((c (lookup-command command)))
|
||||
(if c
|
||||
((command-procedure c) repl)
|
||||
(user-error "Unknown meta command: ~A" command)))))
|
||||
(let ((command (read-command repl)))
|
||||
(cond
|
||||
((eq? command *unspecified*)) ; read error, already signalled; pass.
|
||||
((not (symbol? command))
|
||||
(format #t "Meta-command not a symbol: ~s~%" command))
|
||||
((lookup-command command)
|
||||
=> (lambda (c) ((command-procedure c) repl)))
|
||||
(else
|
||||
(format #t "Unknown meta command: ~A~%" command)))))
|
||||
|
||||
(define-syntax define-meta-command
|
||||
(syntax-rules ()
|
||||
((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
|
||||
(define (name repl)
|
||||
docstring
|
||||
(let* ((expression0
|
||||
(define (handle-read-error form-name key args)
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
|
||||
key form-name 'name)
|
||||
(display-error #f (current-output-port) subr msg args rest))
|
||||
(else
|
||||
(format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
|
||||
key args form-name 'name)))
|
||||
(abort))
|
||||
|
||||
(% (let* ((expression0
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(repl-reader ""
|
||||
(lambda* (#:optional (port (repl-inport repl)))
|
||||
((language-reader (repl-language repl))
|
||||
port (current-module)))))
|
||||
(lambda (k . args)
|
||||
(handle-read-error 'expression0 k args))))
|
||||
...)
|
||||
(apply (lambda* datums
|
||||
(with-output-to-port (repl-outport repl)
|
||||
(lambda () b0 b1 ...)))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((port (open-input-string (read-line repl))))
|
||||
(let lp ((out '()))
|
||||
(let ((x (read port)))
|
||||
(if (eof-object? x)
|
||||
(reverse out)
|
||||
(lp (cons x out))))))))))
|
||||
(lp (cons x out)))))))
|
||||
(lambda (k . args)
|
||||
(handle-read-error #f k args)))))
|
||||
(lambda (k) #f)))) ; the abort handler
|
||||
|
||||
((_ (name repl . datums) docstring b0 b1 ...)
|
||||
(define-meta-command (name repl () . datums)
|
||||
docstring b0 b1 ...))))
|
||||
|
|
@ -153,11 +208,8 @@
|
|||
;;;
|
||||
|
||||
(define-meta-command (help repl . args)
|
||||
"help
|
||||
help GROUP
|
||||
help [-c] COMMAND
|
||||
|
||||
Gives help on the meta-commands available at the REPL.
|
||||
"help [all | GROUP | [-c] COMMAND]
|
||||
Show help.
|
||||
|
||||
With one argument, tries to look up the argument as a group name, giving
|
||||
help on that group if successful. Otherwise tries to look up the
|
||||
|
|
@ -191,16 +243,14 @@ are displayed."
|
|||
((-c ,command) (guard (lookup-command command))
|
||||
(display-command (lookup-command command)))
|
||||
((,command)
|
||||
(user-error "Unknown command or group: ~A" command))
|
||||
(format #t "Unknown command or group: ~A~%" command))
|
||||
((-c ,command)
|
||||
(user-error "Unknown command: ~A" command))
|
||||
(format #t "Unknown command: ~A~%" command))
|
||||
(else
|
||||
(user-error "Bad arguments: ~A" args))))
|
||||
(format #t "Bad arguments: ~A~%" args))))
|
||||
|
||||
(define-meta-command (show repl . args)
|
||||
"show
|
||||
show TOPIC
|
||||
|
||||
"show [TOPIC]
|
||||
Gives information about Guile.
|
||||
|
||||
With one argument, tries to show a particular piece of information;
|
||||
|
|
@ -216,9 +266,9 @@ Without any argument, a list of topics is displayed."
|
|||
((,topic) (guard (lookup-command topic *show-table*))
|
||||
((command-procedure (lookup-command topic *show-table*)) repl))
|
||||
((,command)
|
||||
(user-error "Unknown topic: ~A" command))
|
||||
(format #t "Unknown topic: ~A~%" command))
|
||||
(else
|
||||
(user-error "Bad arguments: ~A" args))))
|
||||
(format #t "Bad arguments: ~A~%" args))))
|
||||
|
||||
(define (warranty repl)
|
||||
"show warranty
|
||||
|
|
@ -291,7 +341,7 @@ Import modules / List those imported."
|
|||
(let ((mod (resolve-interface name)))
|
||||
(if mod
|
||||
(module-use! (current-module) mod)
|
||||
(user-error "No such module: ~A" name))))
|
||||
(format #t "No such module: ~A~%" name))))
|
||||
(if (null? args)
|
||||
(for-each puts (map module-name (module-uses (current-module))))
|
||||
(for-each use args))))
|
||||
|
|
@ -333,7 +383,7 @@ Change languages."
|
|||
;;;
|
||||
|
||||
(define-meta-command (compile repl (form))
|
||||
"compile FORM
|
||||
"compile EXP
|
||||
Generate compiled code."
|
||||
(let ((x (repl-compile repl (repl-parse repl form))))
|
||||
(cond ((objcode? x) (guile:disassemble x))
|
||||
|
|
@ -349,8 +399,8 @@ Compile a file."
|
|||
((@ (language assembly disassemble) disassemble) x))
|
||||
|
||||
(define-meta-command (disassemble repl (form))
|
||||
"disassemble PROGRAM
|
||||
Disassemble a program."
|
||||
"disassemble EXP
|
||||
Disassemble a compiled procedure."
|
||||
(guile:disassemble (repl-eval repl (repl-parse repl form))))
|
||||
|
||||
(define-meta-command (disassemble-file repl file)
|
||||
|
|
@ -364,7 +414,7 @@ Disassemble a file."
|
|||
;;;
|
||||
|
||||
(define-meta-command (time repl (form))
|
||||
"time FORM
|
||||
"time EXP
|
||||
Time execution."
|
||||
(let* ((gc-start (gc-run-time))
|
||||
(tms-start (times))
|
||||
|
|
@ -385,21 +435,15 @@ Time execution."
|
|||
result))
|
||||
|
||||
(define-meta-command (profile repl (form) . opts)
|
||||
"profile FORM
|
||||
"profile EXP
|
||||
Profile execution."
|
||||
;; FIXME opts
|
||||
(apply statprof
|
||||
(make-program (repl-compile repl (repl-parse repl form)))
|
||||
opts))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Debug commands
|
||||
;;;
|
||||
|
||||
(define-meta-command (trace repl (form) . opts)
|
||||
"trace FORM
|
||||
"trace EXP
|
||||
Trace execution."
|
||||
;; FIXME: doc options, or somehow deal with them better
|
||||
(apply vm-trace
|
||||
|
|
@ -407,6 +451,139 @@ Trace execution."
|
|||
(make-program (repl-compile repl (repl-parse repl form)))
|
||||
opts))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Debug commands
|
||||
;;;
|
||||
|
||||
(define-syntax define-stack-command
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (name repl . args) docstring body body* ...)
|
||||
#`(define-meta-command (name repl . args)
|
||||
docstring
|
||||
(let ((debug (repl-debug repl)))
|
||||
(if debug
|
||||
(letrec-syntax
|
||||
((#,(datum->syntax #'repl 'frames)
|
||||
(identifier-syntax (debug-frames debug)))
|
||||
(#,(datum->syntax #'repl 'index)
|
||||
(identifier-syntax
|
||||
(id (debug-index debug))
|
||||
((set! id exp) (set! (debug-index debug) exp))))
|
||||
(#,(datum->syntax #'repl 'cur)
|
||||
(identifier-syntax
|
||||
(vector-ref #,(datum->syntax #'repl 'frames)
|
||||
#,(datum->syntax #'repl 'index)))))
|
||||
body body* ...)
|
||||
(format #t "Nothing to debug.~%"))))))))
|
||||
|
||||
(define-stack-command (backtrace repl #:optional count
|
||||
#:key (width 72) full?)
|
||||
"backtrace [COUNT] [#:width W] [#:full? F]
|
||||
Print a backtrace.
|
||||
|
||||
Print a backtrace of all stack frames, or innermost COUNT frames.
|
||||
If COUNT is negative, the last COUNT frames will be shown."
|
||||
(print-frames frames
|
||||
#:count count
|
||||
#:width width
|
||||
#:full? full?))
|
||||
|
||||
(define-stack-command (up repl #:optional (count 1))
|
||||
"up [COUNT]
|
||||
Select a calling stack frame.
|
||||
|
||||
Select and print stack frames that called this one.
|
||||
An argument says how many frames up to go."
|
||||
(cond
|
||||
((or (not (integer? count)) (<= count 0))
|
||||
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
|
||||
((>= (+ count index) (vector-length frames))
|
||||
(cond
|
||||
((= index (1- (vector-length frames)))
|
||||
(format #t "Already at outermost frame.\n"))
|
||||
(else
|
||||
(set! index (1- (vector-length frames)))
|
||||
(print-frame cur #:index index))))
|
||||
(else
|
||||
(set! index (+ count index))
|
||||
(print-frame cur #:index index))))
|
||||
|
||||
(define-stack-command (down repl #:optional (count 1))
|
||||
"down [COUNT]
|
||||
Select a called stack frame.
|
||||
|
||||
Select and print stack frames called by this one.
|
||||
An argument says how many frames down to go."
|
||||
(cond
|
||||
((or (not (integer? count)) (<= count 0))
|
||||
(format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
|
||||
((< (- index count) 0)
|
||||
(cond
|
||||
((zero? index)
|
||||
(format #t "Already at innermost frame.\n"))
|
||||
(else
|
||||
(set! index 0)
|
||||
(print-frame cur #:index index))))
|
||||
(else
|
||||
(set! index (- index count))
|
||||
(print-frame cur #:index index))))
|
||||
|
||||
(define-stack-command (frame repl #:optional idx)
|
||||
"frame [IDX]
|
||||
Show a frame.
|
||||
|
||||
Show the selected frame.
|
||||
With an argument, select a frame by index, then show it."
|
||||
(cond
|
||||
(idx
|
||||
(cond
|
||||
((or (not (integer? idx)) (< idx 0))
|
||||
(format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
|
||||
((< idx (vector-length frames))
|
||||
(set! index idx)
|
||||
(print-frame cur #:index index))
|
||||
(else
|
||||
(format #t "No such frame.~%"))))
|
||||
(else (print-frame cur #:index index))))
|
||||
|
||||
(define-stack-command (procedure repl)
|
||||
"procedure
|
||||
Print the procedure for the selected frame.
|
||||
|
||||
Foo."
|
||||
(repl-print repl (frame-procedure cur)))
|
||||
|
||||
(define-stack-command (locals repl)
|
||||
"locals
|
||||
Show local variables.
|
||||
|
||||
Show locally-bound variables in the selected frame."
|
||||
(print-locals cur))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Inspection commands
|
||||
;;;
|
||||
|
||||
(define-stack-command (inspect repl (form))
|
||||
"inspect EXP
|
||||
Inspect the result(s) of evaluating EXP."
|
||||
(call-with-values (make-program (repl-compile repl (repl-parse repl form)))
|
||||
(lambda args
|
||||
(for-each %inspect args))))
|
||||
|
||||
(define-meta-command (pretty-print repl (form))
|
||||
"pretty-print EXP
|
||||
Pretty-print the result(s) of evaluating EXP."
|
||||
(call-with-values (make-program (repl-compile repl (repl-parse repl form)))
|
||||
(lambda args
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(run-hook before-print-hook x)
|
||||
(pp x))
|
||||
args))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -26,7 +26,8 @@
|
|||
#:use-module (ice-9 control)
|
||||
#:export (<repl> make-repl repl-language repl-options
|
||||
repl-tm-stats repl-gc-stats repl-inport repl-outport repl-debug
|
||||
repl-welcome repl-prompt repl-read repl-compile repl-eval
|
||||
repl-welcome repl-prompt
|
||||
repl-read repl-compile repl-prepare-eval-thunk repl-eval
|
||||
repl-parse repl-print repl-option-ref repl-option-set!
|
||||
repl-default-option-set! repl-default-prompt-set!
|
||||
puts ->string user-error
|
||||
|
|
@ -152,18 +153,22 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
|
|||
(let ((parser (language-parser (repl-language repl))))
|
||||
(if parser (parser form) form)))
|
||||
|
||||
(define (repl-eval repl form)
|
||||
(let* ((eval (language-evaluator (repl-language repl)))
|
||||
(thunk (if (and eval
|
||||
(define (repl-prepare-eval-thunk repl form)
|
||||
(let* ((eval (language-evaluator (repl-language repl))))
|
||||
(if (and eval
|
||||
(or (null? (language-compilers (repl-language repl)))
|
||||
(assq-ref (repl-options repl) 'interp)))
|
||||
(lambda () (eval form (current-module)))
|
||||
(make-program (repl-compile repl form)))))
|
||||
|
||||
(define (repl-eval repl form)
|
||||
(let ((thunk (repl-prepare-eval-thunk repl form)))
|
||||
(% (thunk))))
|
||||
|
||||
(define (repl-print repl val)
|
||||
(if (not (eq? val *unspecified*))
|
||||
(begin
|
||||
(run-hook before-print-hook val)
|
||||
;; The result of an evaluation is representable in scheme, and
|
||||
;; should be printed with the generic printer, `write'. The
|
||||
;; language-printer is something else: it prints expressions of
|
||||
|
|
|
|||
177
module/system/repl/debug.scm
Normal file
177
module/system/repl/debug.scm
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
;;; Guile VM debugging facilities
|
||||
|
||||
;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; This library is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this library; if not, write to the Free Software
|
||||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (system repl debug)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system vm vm)
|
||||
#:use-module (system vm frame)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 pretty-print)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
|
||||
#:use-module (system vm program)
|
||||
#:export (<debug>
|
||||
make-debug debug? debug-frames debug-index
|
||||
print-locals print-frame print-frames frame->module
|
||||
stack->vector narrow-stack->vector))
|
||||
|
||||
;;; FIXME: add more repl meta-commands: continue, inspect, etc...
|
||||
|
||||
;;;
|
||||
;;; Debugger
|
||||
;;;
|
||||
;;; The actual interaction loop of the debugger is run by the repl. This module
|
||||
;;; simply exports a data structure to hold the debugger state, along with its
|
||||
;;; accessors, and provides some helper functions.
|
||||
;;;
|
||||
|
||||
(define-record <debug> frames index)
|
||||
|
||||
|
||||
|
||||
(define (reverse-hashq h)
|
||||
(let ((ret (make-hash-table)))
|
||||
(hash-for-each
|
||||
(lambda (k v)
|
||||
(hashq-set! ret v (cons k (hashq-ref ret v '()))))
|
||||
h)
|
||||
ret))
|
||||
|
||||
(define* (print-locals frame #:optional (port (current-output-port))
|
||||
#:key (width 72) (per-line-prefix ""))
|
||||
(let ((bindings (frame-bindings frame)))
|
||||
(cond
|
||||
((null? bindings)
|
||||
(format port "~aNo local variables.~%" per-line-prefix))
|
||||
(else
|
||||
(format port "~aLocal variables:~%" per-line-prefix)
|
||||
(for-each
|
||||
(lambda (binding)
|
||||
(format port "~a~4d ~a~:[~; (boxed)~] = ~v:@y\n"
|
||||
per-line-prefix
|
||||
(binding:index binding)
|
||||
(binding:name binding)
|
||||
(binding:boxed? binding)
|
||||
width
|
||||
(let ((x (frame-local-ref frame (binding:index binding))))
|
||||
(if (binding:boxed? binding)
|
||||
(variable-ref x)
|
||||
x))))
|
||||
(frame-bindings frame))))))
|
||||
|
||||
(define* (print-frame frame #:optional (port (current-output-port))
|
||||
#:key index (width 72) (full? #f) (last-source #f))
|
||||
(define (source:pretty-file source)
|
||||
(if source
|
||||
(or (source:file source) "current input")
|
||||
"unknown file"))
|
||||
(let* ((source (frame-source frame))
|
||||
(file (source:pretty-file source))
|
||||
(line (and=> source source:line)))
|
||||
(if (and file (not (equal? file (source:pretty-file last-source))))
|
||||
(format port "~&In ~a:~&" file))
|
||||
(format port "~:[~*~6_~;~5d:~]~:[~*~3_~;~3d~] ~v:@y~%"
|
||||
line line index index width (frame-call-representation frame))
|
||||
(if full?
|
||||
(print-locals frame #:width width
|
||||
#:per-line-prefix " "))))
|
||||
|
||||
(define* (print-frames frames
|
||||
#:optional (port (current-output-port))
|
||||
#:key (width 72) (full? #f) (forward? #f) count)
|
||||
(let* ((len (vector-length frames))
|
||||
(lower-idx (if (or (not count) (positive? count))
|
||||
0
|
||||
(max 0 (+ len count))))
|
||||
(upper-idx (if (and count (negative? count))
|
||||
(1- len)
|
||||
(1- (if count (min count len) len))))
|
||||
(inc (if forward? 1 -1)))
|
||||
(let lp ((i (if forward? lower-idx upper-idx))
|
||||
(last-source #f))
|
||||
(if (<= lower-idx i upper-idx)
|
||||
(let* ((frame (vector-ref frames i)))
|
||||
(print-frame frame port #:index i #:width width #:full? full?
|
||||
#:last-source last-source)
|
||||
(lp (+ i inc) (frame-source frame)))))))
|
||||
|
||||
;; Ideally here we would have something much more syntactic, in that a set! to a
|
||||
;; local var that is not settable would raise an error, and export etc forms
|
||||
;; would modify the module in question: but alack, this is what we have now.
|
||||
;; Patches welcome!
|
||||
(define (frame->module frame)
|
||||
(let ((proc (frame-procedure frame)))
|
||||
(if (program? proc)
|
||||
(let* ((mod (or (program-module proc) (current-module)))
|
||||
(mod* (make-module)))
|
||||
(module-use! mod* mod)
|
||||
(for-each
|
||||
(lambda (binding)
|
||||
(let* ((x (frame-local-ref frame (binding:index binding)))
|
||||
(var (if (binding:boxed? binding) x (make-variable x))))
|
||||
(format #t
|
||||
"~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
|
||||
(binding:boxed? binding)
|
||||
(binding:name binding)
|
||||
(if (variable-bound? var) (variable-ref var) var))
|
||||
(module-add! mod* (binding:name binding) var)))
|
||||
(frame-bindings frame))
|
||||
mod*)
|
||||
(current-module))))
|
||||
|
||||
|
||||
;; TODO:
|
||||
;;
|
||||
;; eval expression in context of frame
|
||||
;; set local variable in frame
|
||||
;; step until next instruction
|
||||
;; step until next function call/return
|
||||
;; step until return from frame
|
||||
;; step until different source line
|
||||
;; step until greater source line
|
||||
;; watch expression
|
||||
;; break on a function
|
||||
;; remove breakpoints
|
||||
;; set printing width
|
||||
;; display a truncated backtrace
|
||||
;; go to a frame by index
|
||||
;; (reuse gdb commands perhaps)
|
||||
;; disassemble a function
|
||||
;; disassemble the current function
|
||||
;; inspect any object
|
||||
;; hm, trace via reassigning global vars. tricksy.
|
||||
;; (state associated with vm ?)
|
||||
|
||||
(define (stack->vector stack)
|
||||
(let* ((len (stack-length stack))
|
||||
(v (make-vector len)))
|
||||
(if (positive? len)
|
||||
(let lp ((i 0) (frame (stack-ref stack 0)))
|
||||
(if (< i len)
|
||||
(begin
|
||||
(vector-set! v i frame)
|
||||
(lp (1+ i) (frame-previous frame))))))
|
||||
v))
|
||||
|
||||
(define (narrow-stack->vector stack . args)
|
||||
(stack->vector (apply make-stack (stack-ref stack 0) args)))
|
||||
|
||||
114
module/system/repl/error-handling.scm
Normal file
114
module/system/repl/error-handling.scm
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
;;; Error handling in the REPL
|
||||
|
||||
;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 3 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
;; 02110-1301 USA
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (system repl error-handling)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system repl debug)
|
||||
#:export (call-with-error-handling
|
||||
with-error-handling))
|
||||
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Error handling via repl debugging
|
||||
;;;
|
||||
|
||||
(define* (call-with-error-handling thunk #:key
|
||||
(on-error 'debug) (post-error 'catch)
|
||||
(pass-keys '(quit)))
|
||||
(let ((in (current-input-port))
|
||||
(out (current-output-port))
|
||||
(err (current-error-port)))
|
||||
(define (with-saved-ports thunk)
|
||||
(with-input-from-port in
|
||||
(lambda ()
|
||||
(with-output-to-port out
|
||||
(lambda ()
|
||||
(with-error-to-port err
|
||||
thunk))))))
|
||||
|
||||
(catch #t
|
||||
(lambda () (%start-stack #t thunk))
|
||||
|
||||
(case post-error
|
||||
((catch)
|
||||
(lambda (key . args)
|
||||
(if (memq key pass-keys)
|
||||
(apply throw key args)
|
||||
(begin
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(with-saved-ports
|
||||
(lambda ()
|
||||
(run-hook before-error-hook)
|
||||
(display-error #f err subr msg args rest)
|
||||
(run-hook after-error-hook)
|
||||
(force-output err))))
|
||||
(else
|
||||
(format err "\nERROR: uncaught throw to `~a', args: ~a\n"
|
||||
key args)))
|
||||
(if #f #f)))))
|
||||
(else
|
||||
(if (procedure? post-error)
|
||||
post-error ; a handler proc
|
||||
(error "Unknown post-error strategy" post-error))))
|
||||
|
||||
(case on-error
|
||||
((debug)
|
||||
(lambda (key . args)
|
||||
(let ((stack (make-stack #t)))
|
||||
(with-saved-ports
|
||||
(lambda ()
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(format #t "Throw to key `~a':\n" key)
|
||||
(display-error stack (current-output-port) subr msg args rest))
|
||||
(else
|
||||
(format #t "Throw to key `~a' with args `~s'." key args)))
|
||||
(format #t "Entering a new prompt. Type `,bt' for a backtrace")
|
||||
(format #t " or `,q' to return to the old prompt.\n")
|
||||
(let ((debug
|
||||
(make-debug
|
||||
(narrow-stack->vector
|
||||
stack
|
||||
;; Cut three frames from the top of the stack:
|
||||
;; make-stack, this one, and the throw handler.
|
||||
3
|
||||
;; Narrow the end of the stack to the most recent
|
||||
;; start-stack.
|
||||
(and (pair? (fluid-ref %stacks))
|
||||
(cdar (fluid-ref %stacks))))
|
||||
0)))
|
||||
((@ (system repl repl) start-repl) #:debug debug)))))))
|
||||
((pass)
|
||||
(lambda (key . args)
|
||||
;; fall through to rethrow
|
||||
#t))
|
||||
(else
|
||||
(if (procedure? on-error)
|
||||
on-error ; pre-unwind handler
|
||||
(error "Unknown on-error strategy" on-error)))))))
|
||||
|
||||
(define-syntax with-error-handling
|
||||
(syntax-rules ()
|
||||
((_ form)
|
||||
(call-with-error-handling (lambda () form)))))
|
||||
|
|
@ -24,12 +24,18 @@
|
|||
#:use-module (system base pmatch)
|
||||
#:use-module (system base compile)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system vm vm)
|
||||
#:use-module (system repl error-handling)
|
||||
#:use-module (system repl common)
|
||||
#:use-module (system repl command)
|
||||
#:use-module (system vm vm)
|
||||
#:use-module (system vm debug)
|
||||
#:export (start-repl))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Meta commands
|
||||
;;;
|
||||
|
||||
(define meta-command-token (cons 'meta 'command))
|
||||
|
||||
(define (meta-reader read env)
|
||||
|
|
@ -53,12 +59,25 @@
|
|||
;;
|
||||
;; Catches read errors, returning *unspecified* in that case.
|
||||
(define (prompting-meta-read repl)
|
||||
(call-with-error-handling
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(repl-reader (lambda () (repl-prompt repl))
|
||||
(meta-reader (language-reader (repl-language repl))
|
||||
(current-module))))
|
||||
#:on-error 'pass))
|
||||
(lambda (key . args)
|
||||
(case key
|
||||
((quit)
|
||||
(apply throw key args))
|
||||
(else
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(format #t "Throw to key `~a' while reading expression:\n" key)
|
||||
(display-error #f (current-output-port) subr msg args rest))
|
||||
(else
|
||||
(format #t "Throw to key `~a' with args `~s' while reading expression.\n"
|
||||
key args)))
|
||||
(force-output)
|
||||
*unspecified*)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -66,31 +85,36 @@
|
|||
;;; The repl
|
||||
;;;
|
||||
|
||||
(define* (start-repl #:optional (lang (current-language)))
|
||||
(let ((repl (make-repl lang))
|
||||
(status #f))
|
||||
(with-fluids ((*repl-stack* (cons repl
|
||||
(or (fluid-ref *repl-stack*) '())))
|
||||
(*debug-input-port*
|
||||
(or (fluid-ref *debug-input-port*) (current-input-port)))
|
||||
(*debug-output-port*
|
||||
(or (fluid-ref *debug-output-port*) (current-output-port))))
|
||||
(define* (start-repl #:optional (lang (current-language)) #:key debug)
|
||||
(run-repl (make-repl lang debug)))
|
||||
|
||||
(define (run-repl repl)
|
||||
(let ((tag (make-prompt-tag "repl ")))
|
||||
(call-with-prompt
|
||||
tag
|
||||
(lambda ()
|
||||
(with-fluids ((*repl-stack*
|
||||
(cons repl (or (fluid-ref *repl-stack*) '()))))
|
||||
(if (null? (cdr (fluid-ref *repl-stack*)))
|
||||
(repl-welcome repl))
|
||||
(let prompt-loop ()
|
||||
(let ((exp (prompting-meta-read repl)))
|
||||
(cond
|
||||
((eqv? exp (if #f #f))) ; read error, pass
|
||||
((eqv? exp *unspecified*)) ; read error, pass
|
||||
((eq? exp meta-command-token)
|
||||
(with-error-handling (meta-command repl)))
|
||||
(catch 'quit
|
||||
(lambda () (meta-command repl))
|
||||
(lambda (k . args)
|
||||
(abort-to-prompt tag args))))
|
||||
((eof-object? exp)
|
||||
(newline)
|
||||
(set! status '()))
|
||||
(abort-to-prompt tag '()))
|
||||
(else
|
||||
;; since the input port is line-buffered, consume up to the
|
||||
;; newline
|
||||
(flush-to-newline)
|
||||
(with-error-handling
|
||||
(call-with-error-handling
|
||||
(lambda ()
|
||||
(catch 'quit
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
|
|
@ -100,15 +124,14 @@
|
|||
(repl-eval repl (repl-parse repl exp))))
|
||||
(lambda l
|
||||
(for-each (lambda (v)
|
||||
(run-hook before-print-hook v)
|
||||
(repl-print repl v))
|
||||
l))))
|
||||
(lambda (k . args)
|
||||
(set! status args))))))
|
||||
(or status
|
||||
(begin
|
||||
(abort-to-prompt tag args)))))))
|
||||
(next-char #f) ;; consume trailing whitespace
|
||||
(prompt-loop))))))))
|
||||
(prompt-loop)))))
|
||||
(lambda (k status)
|
||||
status))))
|
||||
|
||||
(define (next-char wait)
|
||||
(if (or wait (char-ready?))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue