summaryrefslogtreecommitdiff
path: root/module/system/repl/command.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/repl/command.scm')
-rw-r--r--module/system/repl/command.scm301
1 files changed, 239 insertions, 62 deletions
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 (read-datum repl)
- (read (repl-inport repl)))
+(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-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))))
;;;