Besides allowing user-defined meta-commands, this change also refactors
the meta-command machinery to split reading a command's arguments from
the procedure actually implementing it, and hence allows nesting
meta-commands. As an example of such a command, ",in" is added as a new
meta-command.
* module/system/repl/command.scm: Export `define-meta-command'.
(*command-module*): Replaced by the hash table `*command-infos*'.
(command-info, make-command-info, command-info-procedure)
(command-info-arguments-reader): New procedures, encapsulating the
information about a meta-command.
(command-procedure): Adapted to use the `command-info' lookup
procedure.
(read-command-arguments): New auxiliary procedure invoking a command's
argument reader procedure.
(meta-command): Adapted to the split of reading arguments and
executing a command.
(add-meta-command!): New auxiliary procedure, registers a meta
command's procedure and argument reader into `*command-infos* and
`*command-table*.
(define-meta-command): Extended to allow specification of the command's
category; split the argument reader and actual command procedure.
(guile:apropos, guile:load, guile:compile-file, guile:gc): Remove these
aliases, they are unnecessary as we now use a hash table instead of the
module to store the commands.
(in): New meta-command, which evaluates an expression, or alternatively
executes another meta-command, in the context of a specific module.
* doc/ref/scheme-using.texi (Module Commands): Document the `in'
meta-command.
From: Andreas Rottmann <a.rottm...@gmx.at>
Subject: Allow user-defined meta-commands
Besides allowing user-defined meta-commands, this change also refactors
the meta-command machinery to split reading a command's arguments from
the procedure actually implementing it, and hence allows nesting
meta-commands. As an example of such a command, ",in" is added as a new
meta-command.
* module/system/repl/command.scm: Export `define-meta-command'.
(*command-module*): Replaced by the hash table `*command-infos*'.
(command-info, make-command-info, command-info-procedure)
(command-info-arguments-reader): New procedures, encapsulating the
information about a meta-command.
(command-procedure): Adapted to use the `command-info' lookup
procedure.
(read-command-arguments): New auxiliary procedure invoking a command's
argument reader procedure.
(meta-command): Adapted to the split of reading arguments and
executing a command.
(add-meta-command!): New auxiliary procedure, registers a meta
command's procedure and argument reader into `*command-infos* and
`*command-table*.
(define-meta-command): Extended to allow specification of the command's
category; split the argument reader and actual command procedure.
(guile:apropos, guile:load, guile:compile-file, guile:gc): Remove these
aliases, they are unnecessary as we now use a hash table instead of the
module to store the commands.
(in): New meta-command, which evaluates an expression, or alternatively
executes another meta-command, in the context of a specific module.
* doc/ref/scheme-using.texi (Module Commands): Document the `in'
meta-command.
---
doc/ref/scheme-using.texi | 7 ++
module/system/repl/command.scm | 135 +++++++++++++++++++++++++++------------
2 files changed, 100 insertions(+), 42 deletions(-)
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 223295c..7700cbe 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -227,6 +227,13 @@ Load a file in the current module.
List current bindings.
@end deffn
+...@deffn {REPL Command} in module expression
+...@deffnx {REPL Command} in module command [args ...]
+Evaluate an expression, or alternatively, execute another meta-command
+in the context of a module. For example, @samp{,in (foo bar) ,binding}
+will show the bindings in the module @code{(foo bar)}.
+...@end deffn
+
@node Language Commands
@subsubsection Language Commands
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 4fc2038..9933b0d 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -41,7 +41,7 @@
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (statprof)
- #:export (meta-command))
+ #:export (meta-command define-meta-command))
;;;
@@ -50,7 +50,7 @@
(define *command-table*
'((help (help h) (show) (apropos a) (describe d))
- (module (module m) (import use) (load l) (binding b))
+ (module (module m) (import use) (load l) (binding b) (in))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
@@ -74,12 +74,22 @@
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
-(define *command-module* (current-module))
+(define *command-infos* (make-hash-table))
(define (command-name c) (car c))
(define (command-abbrevs c) (cdr c))
-(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-info c) (hashq-ref *command-infos* (command-name c)))
+(define (command-procedure c) (command-info-procedure (command-info c)))
(define (command-doc c) (procedure-documentation (command-procedure c)))
+(define (make-command-info proc arguments-reader)
+ (cons proc arguments-reader))
+
+(define (command-info-procedure info)
+ (car info))
+
+(define (command-info-arguments-reader info)
+ (cdr info))
+
(define (command-usage c)
(let ((doc (command-doc c)))
(substring doc 0 (string-index doc #\newline))))
@@ -148,6 +158,9 @@
(force-output)
*unspecified*)))
+(define (read-command-arguments c repl)
+ ((command-info-arguments-reader (command-info c)) repl))
+
(define read-line
(let ((orig-read-line read-line))
(lambda (repl)
@@ -160,40 +173,56 @@
((not (symbol? command))
(format #t "Meta-command not a symbol: ~s~%" command))
((lookup-command command)
- => (lambda (c) ((command-procedure c) repl)))
+ => (lambda (c)
+ (and=> (read-command-arguments c repl)
+ (lambda (args) (apply (command-procedure c) repl args)))))
(else
(format #t "Unknown meta command: ~A~%" command)))))
+(define (add-meta-command! name category proc argument-reader)
+ (hashq-set! *command-infos* name (make-command-info proc argument-reader))
+ (if category
+ (let ((entry (assq category *command-table*)))
+ (if entry
+ (set-cdr! entry (append (cdr entry) (list (list name))))
+ (set! *command-table*
+ (append *command-table*
+ (list (list category (list name)))))))))
+
(define-syntax define-meta-command
(syntax-rules ()
- ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
- (define (name repl)
- docstring
- (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 ...)))
+ ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...)
+ (add-meta-command!
+ 'name
+ 'category
+ (lambda* (repl expression0 ... . datums)
+ docstring
+ (with-output-to-port (repl-outport repl)
+ (lambda () b0 b1 ...)))
+ (lambda (repl)
+ (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))))
+ ...)
+ (append
+ (list expression0 ...)
+ (catch #t
(lambda ()
(let ((port (open-input-string (read-line repl))))
(let lp ((out '()))
@@ -203,10 +232,18 @@
(lp (cons x out)))))))
(lambda (k . args)
(handle-read-error #f k args)))))
- (lambda (k) #f)))) ; the abort handler
+ (lambda (k) #f))))) ; the abort handler
+
+ ((_ ((name category) repl . datums) docstring b0 b1 ...)
+ (define-meta-command ((name category) repl () . datums)
+ docstring b0 b1 ...))
+
+ ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
+ (define-meta-command ((name #f) repl (expression0 ...) . datums)
+ docstring b0 b1 ...))
((_ (name repl . datums) docstring b0 b1 ...)
- (define-meta-command (name repl () . datums)
+ (define-meta-command ((name #f) repl () . datums)
docstring b0 b1 ...))))
@@ -297,11 +334,10 @@ Version information."
(display *version*)
(newline))
-(define guile:apropos apropos)
(define-meta-command (apropos repl regexp)
"apropos REGEXP
Find bindings/modules/packages."
- (guile:apropos (->string regexp)))
+ (apropos (->string regexp)))
(define-meta-command (describe repl (form))
"describe OBJ
@@ -355,11 +391,10 @@ Import modules / List those imported."
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
-(define guile:load load)
(define-meta-command (load repl file)
"load FILE
Load a file in the current module."
- (guile:load (->string file)))
+ (load (->string file)))
(define-meta-command (binding repl)
"binding
@@ -367,6 +402,24 @@ List current bindings."
(module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
(current-module)))
+(define-meta-command (in repl module command-or-expression . args)
+ "in MODULE COMMAND-OR-EXPRESSION
+Evaluate an expression or command in the context of module."
+ (let ((m (resolve-module module #:ensure #f)))
+ (if m
+ (pmatch command-or-expression
+ (('unquote ,command) (guard (lookup-command command))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module m)
+ (apply (command-procedure (list command)) repl args))))
+ (,expression
+ (guard (null? args))
+ (repl-print repl (eval expression m)))
+ (else
+ (format #t "Invalid arguments to `in': expected a single expression or a command.\n")))
+ (format #t "No such module: ~s\n" module))))
+
;;;
;;; Language commands
@@ -393,11 +446,10 @@ Generate compiled code."
(cond ((objcode? x) (guile:disassemble x))
(else (repl-print repl x)))))
-(define guile:compile-file compile-file)
(define-meta-command (compile-file repl file . opts)
"compile-file FILE
Compile a file."
- (guile:compile-file (->string file) #:opts opts))
+ (compile-file (->string file) #:opts opts))
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
@@ -780,11 +832,10 @@ Pretty-print the result(s) of evaluating EXP."
;;; System commands
;;;
-(define guile:gc gc)
(define-meta-command (gc repl)
"gc
Garbage collection."
- (guile:gc))
+ (gc))
(define-meta-command (statistics repl)
"statistics
--
tg: (01a4f0a..) t/eval-meta-command (depends on: master)
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
