rewrite debugger command loop

* module/system/vm/debug.scm: Rewrite the command loop to have better
  introspection and argument handling.

module/system/vm/debug.scm

@@ -22,10 +22,56 @@
   #:use-module (system base syntax)
   #: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 program)
   #:export (run-debugger debug-pre-unwind-handler))
 
 
+(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 (catch-bad-arguments thunk bad-args-thunk)
+  (catch 'wrong-number-of-args
+    (lambda ()
+      (catch 'keyword-argument-error
+        thunk
+        (lambda (k . args)
+          (bad-args-thunk))))
+    (lambda (k . args)
+      (bad-args-thunk))))
+
+(define (read-args prompt)
+  (define (read* reader)
+    (repl-reader prompt reader))
+  (define (next)
+    (read* read-char))
+  (define (cmd chr)
+    (cond
+     ((eof-object? chr) (list chr))
+     ((char=? chr #\newline) (cmd (next)))
+     ((char-whitespace? chr) (cmd (next)))
+     (else
+      (unread-char chr)
+      (let ((tok (read* read)))
+        (args (list tok) (next))))))
+  (define (args out chr)
+    (cond
+     ((eof-object? chr) (reverse out))
+     ((char=? chr #\newline) (reverse out))
+     ((char-whitespace? chr) (args out (next)))
+     (else
+      (unread-char chr)
+      (let ((tok (read* read)))
+        (args (cons tok out) (next))))))
+  (cmd (next)))
+
 ;;;
 ;;; Debugger
 ;;;
@@ -40,62 +86,166 @@
   (let ((prop (make-object-property)))
     (lambda (vm)
       (or (prop vm)
-          (let ((debugger (make-debugger vm (make-fluid) '() (make-debugger-module))))
+          (let ((debugger (make-debugger vm 0 '() (make-debugger-module))))
             (set! (prop vm) debugger)
             debugger)))))
 
 (define* (run-debugger frame #:optional (vm (the-vm)))
   (let* ((db (vm-debugger vm))
          (level (debugger-level db)))
-    (with-fluids ((level (or (and=> (fluid-ref level) 1+) 0)))
+    (dynamic-wind
-      (debugger-repl db frame))))
+      (lambda () (set! (debugger-level db) (1+ level)))
+      (lambda () (debugger-repl db frame))
+      (lambda () (set! (debugger-level db) level)))))
 
 (define (debugger-repl db frame)
-  (let ((top frame))
+  (let ((top frame)
+        (index 0)
+        (level (debugger-level db)))
     (define (frame-index frame)
       (let lp ((idx 0) (walk top))
         (if (= (frame-return-address frame) (frame-return-address walk))
             idx
             (lp (1+ idx) (frame-previous walk)))))
-    (let loop ()
+
-      (let ((index (frame-index frame))
+    (define-syntax define-command
-            (level (fluid-ref (debugger-level db))))
+      (syntax-rules ()
-        (let ((cmd (repl-reader
+        ((_ ((mod cname alias ...) . args) body ...)
+         (define cname
+           (let ((c (lambda* args body ...)))
+             (set-procedure-property! c 'name 'cname)
+             (module-define! mod 'cname c)
+             (module-add! mod 'alias (module-local-variable mod 'cname))
+             ...
+             c)))))
+
+    (let ((commands (make-module)))
+      (define (prompt)
+        (format #f "~a~a debug> "
+                (if (= level 1)
+                    ""
+                    (format #f "~a:" level))
+                index))
+      
+      (define (print* . vals)
+        (define (print x)
+          (run-hook before-print-hook x)
+          (pretty-print x))
+        (if (and (pair? vals)
+                 (not (and (null? (cdr vals))
+                           (unspecified? (car vals)))))
+            (for-each print vals)))
+
+      (define-command ((commands backtrace bt) #:optional count)
+        "Print a backtrace of all stack frames, or innermost COUNT frames."
+        (display-backtrace (make-stack frame) (current-output-port)))
+      
+      (define-command ((commands quit q continue cont c))
+        "Quit the debugger and let the program continue executing."
+        (throw 'quit))
+      
+      #;
+      (case cmd
+        ((bt)
+         (display-backtrace (make-stack frame) (current-output-port)))
+        ((bindings)
+         (format #t "~a\n" (frame-bindings frame)))
+        ((frame f)
+         (format #t "~s\n" frame))
+        ((up)
+         (let ((prev (frame-previous frame)))
+           (if prev
+               (begin
+                 (set! index (1+ index))
+                 (set! frame prev)
+                 (format #t "~s\n" frame))
+               (format #t "Already at outermost frame.\n"))))
+        ((down)
+         (if (zero? index)
+             (format #t "Already at innermost frame.\n")
+             (begin
+               (set! frame (let lp ((n (1- index)) (frame top))
+                             (if (zero? n)
+                                 frame
+                                 (lp (1- n) (frame-previous top)))))
+               (format #t "~s\n" frame))))
+        ((help ?)
+         (format #t "Type `c' to continue.\n"))
+        (else
+         (format #t "Unknown command: ~A\n" cmd)))
+                
+      (define-command ((commands help h ?) #:optional cmd)
+        "Show this help message."
+        (let ((rhash (reverse-hashq (module-obarray commands))))
+          (define (help-cmd cmd)
+            (let* ((v (module-local-variable commands cmd))
+                   (p (variable-ref v))
+                   (canonical-name (procedure-name p)))
+              ;; la la la
+              (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
+                      canonical-name (program-lambda-list p)
+                      "~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
+                      (delq canonical-name (hashq-ref rhash v))
+                      (procedure-documentation p))))
+          (cond
+           (cmd
+            (cond
+             ((and (symbol? cmd) (module-local-variable commands cmd))
+              (help-cmd cmd))
+             (else
+              (format #t "Invalid command ~s.~%" cmd)
+              (format #t "Try `help' for a list of commands~%"))))
+           (else
+            (let ((names (sort
+                           (hash-map->list
+                            (lambda (k v)
+                              (procedure-name (variable-ref k)))
+                            rhash)
+                           (lambda (x y)
+                             (string<? (symbol->string x)
+                                       (symbol->string y))))))
+              (format #t "Available commands:~%~%")
+              (for-each help-cmd names))))))
+
+      (define (handle cmd . args)
+        (cond
+         ((and (symbol? cmd)
+               (module-local-variable commands cmd))
+          => (lambda (var)
+               (let ((proc (variable-ref var)))
+                 (catch-bad-arguments
+                  (lambda ()
+                    (apply (variable-ref var) args))
+                  (lambda ()
+                    (format (current-error-port) "Invalid arguments to ~a~%"
+                            (procedure-name proc))
+                    (help cmd))))))
+         #;
+         ((and (integer? cmd) (exact? cmd))
+          (nth cmd))
+         ((eof-object? cmd)
+          (newline)
+          (throw 'quit))
+         (else
+          (format (current-error-port)
+                  "~&Unknown command: ~a. Try `help'.~%" cmd)
+          *unspecified*)))
+
+      (catch 'quit
+        (lambda ()
+          (let loop ()
+            (call-with-values
+                (lambda ()
+                  (apply
+                   handle
+                   (save-module-excursion
                     (lambda ()
-                      (format #f "debug[~a@~a]> " level index))
+                      (set-current-module commands)
-                    read)))
+                      (read-args prompt)))))
-          (if (not (or (eof-object? cmd)
+              print*)
-                       (memq cmd '(q quit c continue))))
+            (loop)))
-              (begin
+        (lambda (k . args)
-                (case cmd
+          (apply values args))))))
-                  ((bt)
-                   (display-backtrace (make-stack frame) (current-output-port)))
-                  ((bindings)
-                   (format #t "~a\n" (frame-bindings frame)))
-                  ((frame f)
-                   (format #t "~s\n" frame))
-                  ((up)
-                   (let ((prev (frame-previous frame)))
-                     (if prev
-                         (begin
-                           (set! index (1+ index))
-                           (set! frame prev)
-                           (format #t "~s\n" frame))
-                         (format #t "Already at outermost frame.\n"))))
-                  ((down)
-                   (if (zero? index)
-                       (format #t "Already at innermost frame.\n")
-                       (begin
-                         (set! frame (let lp ((n (1- index)) (frame top))
-                                       (if (zero? n)
-                                           frame
-                                           (lp (1- n) (frame-previous top)))))
-                         (format #t "~s\n" frame))))
-                  ((help ?)
-                   (format #t "Type `c' to continue.\n"))
-                  (else
-                   (format #t "Unknown command: ~A\n" cmd)))
-                (loop))))))))
 
 ;; things this debugger should do:
 ;;