From 33df2ec719d281c70a5c7595dceee9f47770e910 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 9 Jul 2010 17:04:34 +0200 Subject: [PATCH] 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. --- module/Makefile.am | 6 +- module/system/repl/command.scm | 299 ++++++++++++++++++++------ module/system/repl/common.scm | 19 +- module/system/repl/debug.scm | 177 +++++++++++++++ module/system/repl/error-handling.scm | 114 ++++++++++ module/system/repl/repl.scm | 125 ++++++----- 6 files changed, 619 insertions(+), 121 deletions(-) create mode 100644 module/system/repl/debug.scm create mode 100644 module/system/repl/error-handling.scm diff --git a/module/Makefile.am b/module/Makefile.am index 6e3e064c7..d2ab2aeb5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -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 \ diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 0c3d70715..7b092e634 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.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 - (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)))) ;;; diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 2d50d441f..9d71e9939 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -26,7 +26,8 @@ #:use-module (ice-9 control) #:export ( 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 , 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 diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm new file mode 100644 index 000000000..f9b6af280 --- /dev/null +++ b/module/system/repl/debug.scm @@ -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 ( + 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 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))) + diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm new file mode 100644 index 000000000..d7d43bd71 --- /dev/null +++ b/module/system/repl/error-handling.scm @@ -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))))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 48c6eb0f8..ce309a9b9 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -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?))