meta-commands read off their own arguments

* module/system/repl/command.scm: Update copyright.
  (meta-command): Rework so that it's the various meta-commands that do
  the reading for their arguments. This way you can compile forms that
  span more than one line, and forms that need to be read with another
  language's reader.
  (define-meta-command): New helper macro. Update commands to use it.
  (help): Allow ,help on commands too.

* module/system/repl/repl.scm: Update copyright.
  (start-repl): Adjust to give meta-command what it wants.

module/system/repl/command.scm

@@ -1,21 +1,21 @@
 ;;; Repl commands
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
-;; This program is free software; you can redistribute it and/or modify
+;; This library is free software; you can redistribute it and/or
-;; it under the terms of the GNU General Public License as published by
+;; modify it under the terms of the GNU Lesser General Public
-;; the Free Software Foundation; either version 2, or (at your option)
+;; License as published by the Free Software Foundation; either
-;; any later version.
+;; version 3 of the License, or (at your option) any later version.
 ;; 
-;; This program is distributed in the hope that it will be useful,
+;; 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; GNU General Public License for more details.
+;; Lesser General Public License for more details.
 ;; 
-;; You should have received a copy of the GNU General Public License
+;; You should have received a copy of the GNU Lesser General Public
-;; along with this program; see the file COPYING.  If not, write to
+;; License along with this library; if not, write to the Free Software
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;; Boston, MA 02111-1307, USA.
+;; 02110-1301 USA
 
 ;;; Code:
 
@@ -27,7 +27,7 @@
   #:use-module (system vm objcode)
   #:use-module (system vm program)
   #:use-module (system vm vm)
-  #:autoload (system base language) (lookup-language)
+  #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm debug) (vm-debugger vm-backtrace)
   #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
   #:autoload (system vm profile) (vm-profile)
@@ -35,6 +35,7 @@
   #:use-module (ice-9 session)
   #:use-module (ice-9 documentation)
   #:use-module (ice-9 and-let-star)
+  #:use-module (ice-9 rdelim)
   #:export (meta-command))
 
 
@@ -109,33 +110,66 @@
   (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
     (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
 
-(define (meta-command repl line)
+(define (read-datum repl)
-  (let ((input (call-with-input-string (string-append "(" line ")") read)))
+  (read))
-    (if (not (null? input))
+
-	(do ((key (car input))
+(define read-line
-	     (args (cdr input) (cdr args))
+  (let ((orig-read-line read-line))
-	     (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+    (lambda (repl)
-	    ((or (null? args)
+      (orig-read-line))))
-		 (not (symbol? (car args)))
+
-		 (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+(define (meta-command repl)
-	     (let ((c (lookup-command key)))
+  (let ((command (read-datum repl)))
-	       (if c
+    (if (not (symbol? command))
-		   (cond ((memq #:h opts) (display-command c))
+        (user-error "Meta-command not a symbol: ~s" command))
-			 (else (apply (command-procedure c)
+    (let ((c (lookup-command command)))
-				      repl (append! args (reverse! opts)))))
+      (if c
-		   (user-error "Unknown meta command: ~A" key))))))))
+          ((command-procedure c) repl)
+          (user-error "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
+               (with-fluid* current-reader
+                            (language-reader (repl-language repl))
+                 (lambda () (repl-reader ""))))
+              ...)
+         (apply (lambda datums 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))))))))))
+    ((_ (name repl . datums) docstring b0 b1 ...)
+     (define-meta-command (name repl () . datums)
+       docstring b0 b1 ...))))
+
 
 
 ;;;
 ;;; Help commands
 ;;;
 
-(define (help repl . args)
+(define-meta-command (help repl . args)
-  "help [GROUP]
+  "help 
-List available meta commands.
+help GROUP
-A command group name can be given as an optional argument.
+help [-c] COMMAND
+
+Gives help on the meta-commands available at the REPL.
+
+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
+argument as a command, giving help on the command.
+
+If there is a command whose name is also a group name, use the ,help
+-c COMMAND form to give help on the command instead of the group.
+
 Without any argument, a list of help commands and command groups
-are displayed, as you have already seen ;)"
+are displayed."
   (pmatch args
     (()
      (display-group (lookup-group 'help))
@@ -154,23 +188,30 @@ are displayed, as you have already seen ;)"
      (for-each display-group *command-table*))
     ((,group) (guard (lookup-group group))
      (display-group (lookup-group group)))
+    ((,command) (guard (lookup-command command))
+     (display-command (lookup-command command)))
+    ((-c ,command) (guard (lookup-command command))
+     (display-command (lookup-command command)))
+    ((,command)
+     (user-error "Unknown command or group: ~A" command))
+    ((-c ,command)
+     (user-error "Unknown command: ~A" command))
     (else
-     (user-error "Unknown command group: ~A" (car args)))))
+     (user-error "Bad arguments: ~A" args))))
 
 (define guile:apropos apropos)
-(define (apropos repl regexp)
+(define-meta-command (apropos repl regexp)
   "apropos REGEXP
 Find bindings/modules/packages."
   (guile:apropos (->string regexp)))
 
-(define (describe repl obj)
+(define-meta-command (describe repl (form))
   "describe OBJ
 Show description/documentation."
-  (display (object-documentation
+  (display (object-documentation (repl-eval repl (repl-parse repl form))))
-            (repl-eval repl (repl-parse repl obj))))
   (newline))
 
-(define (option repl . args)
+(define-meta-command (option repl . args)
   "option [KEY VALUE]
 List/show/set options."
   (pmatch args
@@ -190,7 +231,7 @@ List/show/set options."
               (apply vm-trace-on vm val)
               (vm-trace-off vm))))))))
 
-(define (quit repl)
+(define-meta-command (quit repl)
   "quit
 Quit this session."
   (throw 'quit))
@@ -200,7 +241,7 @@ Quit this session."
 ;;; Module commands
 ;;;
 
-(define (module repl . args)
+(define-meta-command (module repl . args)
   "module [MODULE]
 Change modules / Show current module."
   (pmatch args
@@ -209,7 +250,7 @@ Change modules / Show current module."
      (set-current-module (resolve-module mod-name)))
     (,mod-name (set-current-module (resolve-module mod-name)))))
 
-(define (import repl . args)
+(define-meta-command (import repl . args)
   "import [MODULE ...]
 Import modules / List those imported."
   (let ()
@@ -222,7 +263,7 @@ Import modules / List those imported."
         (for-each puts (map module-name (module-uses (current-module))))
         (for-each use args))))
 
-(define (load repl file . opts)
+(define-meta-command (load repl file . opts)
   "load FILE
 Load a file in the current module.
 
@@ -233,7 +274,7 @@ Load a file in the current module.
 		      (apply load-file file opts))))
     (vm-load (repl-vm repl) objcode)))
 
-(define (binding repl . opts)
+(define-meta-command (binding repl)
   "binding
 List current bindings."
   (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
@@ -244,7 +285,7 @@ List current bindings."
 ;;; Language commands
 ;;;
 
-(define (language repl name)
+(define-meta-command (language repl name)
   "language LANGUAGE
 Change languages."
   (set! (repl-language repl) (lookup-language name))
@@ -255,7 +296,7 @@ Change languages."
 ;;; Compile commands
 ;;;
 
-(define (compile repl form . opts)
+(define-meta-command (compile repl (form) . opts)
   "compile FORM
 Generate compiled code.
 
@@ -270,7 +311,7 @@ Generate compiled code.
           (else (repl-print repl x)))))
 
 (define guile:compile-file compile-file)
-(define (compile-file repl file . opts)
+(define-meta-command (compile-file repl file . opts)
   "compile-file FILE
 Compile a file."
   (guile:compile-file (->string file) #:opts opts))
@@ -278,12 +319,12 @@ Compile a file."
 (define (guile:disassemble x)
   ((@ (language assembly disassemble) disassemble) x))
 
-(define (disassemble repl prog)
+(define-meta-command (disassemble repl (form))
   "disassemble PROGRAM
 Disassemble a program."
-  (guile:disassemble (repl-eval repl (repl-parse repl prog))))
+  (guile:disassemble (repl-eval repl (repl-parse repl form))))
 
-(define (disassemble-file repl file)
+(define-meta-command (disassemble-file repl file)
   "disassemble-file FILE
 Disassemble a file."
   (guile:disassemble (load-objcode (->string file))))
@@ -293,7 +334,7 @@ Disassemble a file."
 ;;; Profile commands
 ;;;
 
-(define (time repl form)
+(define-meta-command (time repl (form))
   "time FORM
 Time execution."
   (let* ((vms-start (vm-stats (repl-vm repl)))
@@ -316,7 +357,7 @@ Time execution."
 	    (get identity gc-start gc-end))
     result))
 
-(define (profile repl form . opts)
+(define-meta-command (profile repl form . opts)
   "profile FORM
 Profile execution."
   (apply vm-profile
@@ -329,17 +370,17 @@ Profile execution."
 ;;; Debug commands
 ;;;
 
-(define (backtrace repl)
+(define-meta-command (backtrace repl)
   "backtrace
 Display backtrace."
   (vm-backtrace (repl-vm repl)))
 
-(define (debugger repl)
+(define-meta-command (debugger repl)
   "debugger
 Start debugger."
   (vm-debugger (repl-vm repl)))
 
-(define (trace repl form . opts)
+(define-meta-command (trace repl form . opts)
   "trace FORM
 Trace execution.
 
@@ -351,7 +392,7 @@ Trace execution.
          (repl-compile repl (repl-parse repl form))
          opts))
 
-(define (step repl)
+(define-meta-command (step repl)
   "step FORM
 Step execution."
   (display "Not implemented yet\n"))
@@ -362,12 +403,12 @@ Step execution."
 ;;;
 
 (define guile:gc gc)
-(define (gc repl)
+(define-meta-command (gc repl)
   "gc
 Garbage collection."
   (guile:gc))
 
-(define (statistics repl)
+(define-meta-command (statistics repl)
   "statistics
 Display statistics."
   (let ((this-tms (times))

module/system/repl/repl.scm

@@ -1,21 +1,21 @@
 ;;; Read-Eval-Print Loop
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
-;; This program is free software; you can redistribute it and/or modify
+;; This library is free software; you can redistribute it and/or
-;; it under the terms of the GNU General Public License as published by
+;; modify it under the terms of the GNU Lesser General Public
-;; the Free Software Foundation; either version 2, or (at your option)
+;; License as published by the Free Software Foundation; either
-;; any later version.
+;; version 3 of the License, or (at your option) any later version.
 ;; 
-;; This program is distributed in the hope that it will be useful,
+;; 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; GNU General Public License for more details.
+;; Lesser General Public License for more details.
 ;; 
-;; You should have received a copy of the GNU General Public License
+;; You should have received a copy of the GNU Lesser General Public
-;; along with this program; see the file COPYING.  If not, write to
+;; License along with this library; if not, write to the Free Software
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;; Boston, MA 02111-1307, USA.
+;; 02110-1301 USA
 
 ;;; Code:
 
@@ -28,7 +28,6 @@
   #:use-module (system repl command)
   #:use-module (system vm vm)
   #:use-module (system vm debug)
-  #:use-module (ice-9 rdelim)
   #:export (start-repl call-with-backtrace))
 
 (define meta-command-token (cons 'meta 'command))
@@ -103,7 +102,7 @@
         (cond
          ((eqv? exp (if #f #f))) ; read error, pass
          ((eq? exp meta-command-token)
-          (with-backtrace (meta-command repl (read-line))))
+          (with-backtrace (meta-command repl)))
          ((eof-object? exp)
           (newline)
           (set! status '()))