[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-37-g589520b

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=589520bc59981bcf60f4f348961f57301731c438

The branch, master has been updated
       via  589520bc59981bcf60f4f348961f57301731c438 (commit)
       via  b9badc35ab555e92812a16a0b91186c887d01f7c (commit)
      from  c939b1275bd1f8fce2006c4da6597a323addc04e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 589520bc59981bcf60f4f348961f57301731c438
Author: Andy Wingo <address@hidden>
Date:   Sun Sep 19 11:32:47 2010 +0200

    add ,traps ,delete ,disable ,enable
    
    * module/system/repl/command.scm (traps, delete, disable, enable): New
      meta-commands.

commit b9badc35ab555e92812a16a0b91186c887d01f7c
Author: Andy Wingo <address@hidden>
Date:   Sun Sep 19 11:16:32 2010 +0200

    implement breakpoints in the repl
    
    * module/system/vm/trap-state.scm: New file, tracks a VM-specific set of
      traps.
    * module/Makefile.am: Add trap-state.scm.
    
    * module/system/repl/error-handling.scm: While in a with-error-handling
      block, bind a default trap handler that invokes a recursive prompt.
    
    * module/system/repl/command.scm: Add a `break' repl meta-command.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                    |    1 +
 module/system/repl/command.scm        |   74 ++++++++++++--
 module/system/repl/error-handling.scm |   29 +++++-
 module/system/vm/trap-state.scm       |  174 +++++++++++++++++++++++++++++++++
 4 files changed, 268 insertions(+), 10 deletions(-)
 create mode 100644 module/system/vm/trap-state.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 37e27ee..1202e20 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -314,6 +314,7 @@ SYSTEM_SOURCES =                            \
   system/vm/program.scm                                \
   system/vm/trace.scm                          \
   system/vm/traps.scm                          \
+  system/vm/trap-state.scm                     \
   system/vm/vm.scm                             \
   system/foreign.scm                           \
   system/xref.scm                              \
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index c98d328..ed1cba9 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -27,6 +27,7 @@
   #:use-module (system repl debug)
   #:use-module (system vm objcode)
   #:use-module (system vm program)
+  #:use-module (system vm trap-state)
   #:use-module (system vm vm)
   #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm trace) (vm-trace)
@@ -55,7 +56,9 @@
              (disassemble x) (disassemble-file xx))
     (profile  (time t) (profile pr) (trace tr))
     (debug    (backtrace bt) (up) (down) (frame fr)
-              (procedure proc) (locals) (error-message error))
+              (procedure proc) (locals) (error-message error)
+              (break br)
+              (traps) (delete del) (disable) (enable))
     (inspect  (inspect i) (pretty-print pp))
     (system   (gc) (statistics stat) (option o)
               (quit q continue cont))))
@@ -476,14 +479,6 @@ Trace execution."
                    body body* ...)
                  (format #t "Nothing to debug.~%"))))))))
 
-(define-stack-command (error-message repl)
-  "error-message
-Show error message.
-
-Display the message associated with the error that started the current
-debugging REPL."
-  (format #t "~a~%" (if (string? message) message "No error message")))
-
 (define-stack-command (backtrace repl #:optional count
                                  #:key (width 72) full?)
   "backtrace [COUNT] [#:width W] [#:full? F]
@@ -566,6 +561,67 @@ Show local variables.
 Show locally-bound variables in the selected frame."
   (print-locals cur))
 
+(define-stack-command (error-message repl)
+  "error-message
+Show error message.
+
+Display the message associated with the error that started the current
+debugging REPL."
+  (format #t "~a~%" (if (string? message) message "No error message")))
+
+(define-meta-command (break repl (form))
+  "break PROCEDURE
+Break on calls to PROCEDURE.
+
+Starts a recursive prompt when PROCEDURE is called."
+  (let ((proc (repl-eval repl (repl-parse repl form))))
+    (if (not (procedure? proc))
+        (error "Not a procedure: ~a" proc)
+        (let ((idx (add-trap-at-procedure-call! proc)))
+          (format #t "Added breakpoint ~a at ~a.~%" idx proc)))))
+
+(define-meta-command (traps repl)
+  "traps
+Show the set of currently attached traps.
+
+Show the set of currently attached traps (breakpoints)."
+  (let ((traps (list-traps)))
+    (if (null? traps)
+        (format #t "No traps enabled.~%")
+        (for-each (lambda (idx name)
+                    (format #t "  ~a: ~a~a~%"
+                            idx name
+                            (if (trap-enabled? idx) "" " (disabled)")))
+                  (map car traps) (map cdr traps)))))
+
+(define-meta-command (delete repl idx)
+  "delete IDX
+Delete a trap.
+
+Delete a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (delete-trap! idx)))
+
+(define-meta-command (disable repl idx)
+  "disable IDX
+Disable a trap.
+
+Disable a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (disable-trap! idx)))
+
+(define-meta-command (enable repl idx)
+  "enable IDX
+Enable a trap.
+
+Enable a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (enable-trap! idx)))
+
+
 
 ;;;
 ;;; Inspection commands
diff --git a/module/system/repl/error-handling.scm 
b/module/system/repl/error-handling.scm
index e77ea96..dc2367b 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -21,6 +21,7 @@
 
 (define-module (system repl error-handling)
   #:use-module (system base pmatch)
+  #:use-module (system vm trap-state)
   #:use-module (system repl debug)
   #:export (call-with-error-handling
             with-error-handling))
@@ -56,8 +57,34 @@
               (with-error-to-port err
                 thunk))))))
 
+    (define (debug-trap-handler frame trap-idx trap-name)
+      (let* ((tag (and (pair? (fluid-ref %stacks))
+                       (cdar (fluid-ref %stacks))))
+             (stack (narrow-stack->vector
+                     (make-stack frame)
+                     ;; Take the stack from the given frame, cutting 0
+                     ;; frames.
+                     0
+                     ;; Narrow the end of the stack to the most recent
+                     ;; start-stack.
+                     tag
+                     ;; And one more frame, because %start-stack
+                     ;; invoking the start-stack thunk has its own frame
+                     ;; too.
+                     0 (and tag 1)))
+             (error-msg (format #f "Trap ~d: ~a" trap-idx trap-name))
+             (debug (make-debug stack 0 error-msg)))
+        (with-saved-ports
+         (lambda ()
+           (format #t "~a~%" error-msg)
+           (format #t "Entering a new prompt.  ")
+           (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+           ((@ (system repl repl) start-repl) #:debug debug)))))
+
     (catch #t
-      (lambda () (%start-stack #t thunk))
+      (lambda () 
+        (with-default-trap-handler debug-trap-handler
+          (lambda () (%start-stack #t thunk))))
 
       (case post-error
         ((report)
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
new file mode 100644
index 0000000..024bb20
--- /dev/null
+++ b/module/system/vm/trap-state.scm
@@ -0,0 +1,174 @@
+;;; trap-state.scm: a set of traps
+
+;; Copyright (C)  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
+
+;;; Commentary:
+;;;
+;;; Code:
+
+(define-module (system vm trap-state)
+  #:use-module (system base syntax)
+  #:use-module (system vm vm)
+  #:use-module (system vm traps)
+  #:export (list-traps
+            trap-enabled?
+            enable-trap!
+            disable-trap!
+            delete-trap!
+            
+            with-default-trap-handler
+            install-trap-handler!
+
+            add-trap-at-procedure-call!))
+
+(define %default-trap-handler (make-fluid))
+
+(define (with-default-trap-handler handler thunk)
+  (with-fluids ((%default-trap-handler handler))
+    (thunk)))
+
+(define (default-trap-handler frame idx trap-name)
+  (if %default-trap-handler
+      ((fluid-ref %default-trap-handler) frame idx trap-name)
+      (warn "Trap with no handler installed" frame idx trap-name)))
+
+(define-record <trap-wrapper>
+  index
+  enabled?
+  trap
+  name)
+
+(define-record <trap-state>
+  (handler default-trap-handler)
+  (next-idx 0)
+  (wrappers '()))
+
+(define (trap-wrapper<? t1 t2)
+  (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
+
+;; The interface that a trap provides to the outside world is that of a
+;; procedure, which when called disables the trap, and returns a
+;; procedure to enable the trap. Perhaps this is a bit too odd and we
+;; should fix this.
+(define (enable-trap-wrapper! wrapper)
+  (if (trap-wrapper-enabled? wrapper)
+      (error "Trap already enabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #t))))
+
+(define (disable-trap-wrapper! wrapper)
+  (if (not (trap-wrapper-enabled? wrapper))
+      (error "Trap already disabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #f))))
+
+(define (add-trap-wrapper! trap-state wrapper)
+  (set! (trap-state-wrappers trap-state)
+        (append (trap-state-wrappers trap-state) (list wrapper)))
+  (trap-wrapper-index wrapper))
+
+(define (remove-trap-wrapper! trap-state wrapper)
+  (delq wrapper (trap-state-wrappers trap-state)))
+
+(define (wrapper-at-index trap-state idx)
+  (let lp ((wrappers (trap-state-wrappers trap-state)))
+    (cond
+     ((null? wrappers)
+      (warn "no wrapper found with index in trap-state" idx)
+      #f)
+     ((= (trap-wrapper-index (car wrappers)) idx)
+      (car wrappers))
+     (else
+      (lp (cdr wrappers))))))
+
+(define (next-index! trap-state)
+  (let ((idx (trap-state-next-idx trap-state)))
+    (set! (trap-state-next-idx trap-state) (1+ idx))
+    idx))
+
+(define (handler-for-index trap-state idx)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx))
+          (handler (trap-state-handler trap-state)))
+      (if wrapper
+          (handler frame
+                   (trap-wrapper-index wrapper)
+                   (trap-wrapper-name wrapper))))))
+
+
+
+;;;
+;;; VM-local trap states
+;;;
+
+(define *trap-states* (make-weak-key-hash-table))
+
+(define (trap-state-for-vm vm)
+  (or (hashq-ref *trap-states* vm)
+      (let ((ts (make-trap-state)))
+        (hashq-set! *trap-states* vm ts)
+        (trap-state-for-vm vm))))
+
+(define (the-trap-state)
+  (trap-state-for-vm (the-vm)))
+
+
+
+;;;
+;;; API
+;;;
+
+(define* (list-traps #:optional (trap-state (the-trap-state)))
+  (map (lambda (wrapper)
+         (cons (trap-wrapper-index wrapper)
+               (trap-wrapper-name wrapper)))
+       (trap-state-wrappers trap-state)))
+
+(define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         trap-wrapper-enabled?))
+
+(define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         enable-trap-wrapper!))
+
+(define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         disable-trap-wrapper!))
+
+(define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         (lambda (wrapper)
+           (if (trap-wrapper-enabled? wrapper)
+               (disable-trap-wrapper! wrapper))
+           (remove-trap-wrapper! trap-state wrapper))))
+
+(define* (install-trap-handler! handler #:optional (trap-state 
(the-trap-state)))
+  (set! (trap-state-handler trap-state) handler))
+
+(define* (add-trap-at-procedure-call! proc #:optional (trap-state 
(the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trap-at-procedure-call
+                proc
+                (handler-for-index trap-state idx))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "breakpoint at ~a" proc)))))


hooks/post-receive
-- 
GNU Guile