mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

integrate the debugger into the repl

Browse source 
* 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 2010-07-09 17:04:34 +02:00
parent ddfb5e2bb0
commit 33df2ec719
6 changed files with 619 additions and 121 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/Makefile.am
View file

@ -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 \

299
module/system/repl/command.scm
View file

@ -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
(repl-reader ""
(lambda* (#:optional (port (repl-inport repl)))
((language-reader (repl-language repl))
port (current-module)))))
...)
(apply (lambda* datums
(with-output-to-port (repl-outport repl)
(lambda () b0 b1 ...)))
(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))))))))))
(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)))))))
(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))))
;;;

19
module/system/repl/common.scm
View file

@ -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-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* ((eval (language-evaluator (repl-language repl)))
(thunk (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)))))
(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
View 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
View 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)))))

125
module/system/repl/repl.scm
View file

@ -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
(lambda ()
(repl-reader (lambda () (repl-prompt repl))
(meta-reader (language-reader (repl-language repl))
(current-module))))
#:on-error 'pass))
(catch #t
(lambda ()
(repl-reader (lambda () (repl-prompt repl))
(meta-reader (language-reader (repl-language repl))
(current-module))))
(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,49 +85,53 @@
;;; 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))))
(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
((eq? exp meta-command-token)
(with-error-handling (meta-command repl)))
((eof-object? exp)
(newline)
(set! status '()))
(else
;; since the input port is line-buffered, consume up to the
;; newline
(flush-to-newline)
(with-error-handling
(catch 'quit
(lambda ()
(call-with-values
(lambda ()
(run-hook before-eval-hook exp)
(start-stack #t
(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
(next-char #f) ;; consume trailing whitespace
(prompt-loop))))))))
(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 *unspecified*)) ; read error, pass
((eq? exp meta-command-token)
(catch 'quit
(lambda () (meta-command repl))
(lambda (k . args)
(abort-to-prompt tag args))))
((eof-object? exp)
(newline)
(abort-to-prompt tag '()))
(else
;; since the input port is line-buffered, consume up to the
;; newline
(flush-to-newline)
(call-with-error-handling
(lambda ()
(catch 'quit
(lambda ()
(call-with-values
(lambda ()
(run-hook before-eval-hook exp)
(start-stack #t
(repl-eval repl (repl-parse repl exp))))
(lambda l
(for-each (lambda (v)
(repl-print repl v))
l))))
(lambda (k . args)
(abort-to-prompt tag args)))))))
(next-char #f) ;; consume trailing whitespace
(prompt-loop)))))
(lambda (k status)
status))))
(define (next-char wait)
(if (or wait (char-ready?))