[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-148-gc6025e7

[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=c6025e76ffb38cff709097b356df61c7ab109e38

The branch, master has been updated
       via  c6025e76ffb38cff709097b356df61c7ab109e38 (commit)
       via  df067433a537a5e12e2b06e5dc72e593b097316c (commit)
       via  6a4a1ef0f4d4f97f5b5c423c919bef4294a6e662 (commit)
       via  ee02e238a36fb1fb2f5308ce56bc9f95dbb1d955 (commit)
       via  586aff5a27fc880b8f80e20352e3bad41c75616c (commit)
       via  2c04cf390b832ec28fac33df5c4a77e00bcd31eb (commit)
      from  35c46aad664835e07ab0cb4a0d7f93632fb42f14 (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 c6025e76ffb38cff709097b356df61c7ab109e38
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:53:58 2010 +0200

    add ,finish repl meta-command
    
    * module/system/repl/command.scm (finish): New REPL meta command. Uses
      fancy prompt stuff.

commit df067433a537a5e12e2b06e5dc72e593b097316c
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:53:29 2010 +0200

    (system vm trap-state): add-trap-at-frame-finish!
    
    * module/system/vm/traps.scm: Fix a comment.
    
    * module/system/vm/trap-state.scm (<trap-state>): Add next-ephemeral-idx
      slot.
      (wrapper-at-index): Use eqv? instead of = to avoid type errors in user
      inputs.
      (next-ephemeral-index!, ephemeral-handler-for-index): New functions,
      allocate ephemeral trap ids for functions to be called only once.
      (add-trap-at-frame-finish!): New export, traps when a frame finishes.

commit 6a4a1ef0f4d4f97f5b5c423c919bef4294a6e662
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:51:44 2010 +0200

    (system vm frame): frame-return-values
    
    * module/system/vm/frame.scm (frame-return-values): New exported
      function, gives the return values for a frame.
    * module/system/vm/trace.scm: Remove frame-return-values from here.

commit ee02e238a36fb1fb2f5308ce56bc9f95dbb1d955
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:50:57 2010 +0200

    debug-trap-handler ephemeral trap enhancement
    
    * module/system/repl/error-handling.scm (call-with-error-handling): If
      the given index is false, assume this was an ephemeral trap, and don't
      print a welcome message or reference the trap by index.

commit 586aff5a27fc880b8f80e20352e3bad41c75616c
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:49:13 2010 +0200

    (system repl debug): add frame->stack-vector
    
    * module/system/repl/debug.scm (frame->stack-vector): New public
      function.

commit 2c04cf390b832ec28fac33df5c4a77e00bcd31eb
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 5 21:48:27 2010 +0200

    fix embarrassing error preventing ,del from working
    
    * module/system/vm/trap-state.scm (remove-trap-wrapper!): Oops, fix
      newbie error regarding delq and mutation.

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

Summary of changes:
 module/system/repl/command.scm        |   35 ++++++++++++++++++++++++++++++
 module/system/repl/debug.scm          |   18 ++++++++++++++-
 module/system/repl/error-handling.scm |   12 +++++++---
 module/system/vm/frame.scm            |   12 +++++++++-
 module/system/vm/trace.scm            |    7 ------
 module/system/vm/trap-state.scm       |   38 ++++++++++++++++++++++++++++++--
 module/system/vm/traps.scm            |    2 +-
 7 files changed, 107 insertions(+), 17 deletions(-)

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 4fc79a6..d23c6c4 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -29,6 +29,7 @@
   #:use-module (system vm program)
   #:use-module (system vm trap-state)
   #:use-module (system vm vm)
+  #:use-module ((system vm frame) #:select (frame-return-values))
   #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm trace) (vm-trace)
   #:autoload (system vm profile) (vm-profile)
@@ -58,6 +59,7 @@
     (debug    (backtrace bt) (up) (down) (frame fr)
               (procedure proc) (locals) (error-message error)
               (break br bp) (break-at-source break-at bs)
+              (finish)
               (tracepoint tp)
               (traps) (delete del) (disable) (enable)
               (registers regs))
@@ -592,6 +594,39 @@ Note that the given source location must be inside a 
procedure."
     (let ((idx (add-trap-at-source-location! file line)))
       (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
 
+(define-stack-command (finish repl)
+  "finish
+Run until the current frame finishes.
+
+Resume execution, breaking when the current frame finishes."
+  (let ((msg (format #f "Return from ~a" cur)))
+    (define resume-repl
+      ;; Capture the dynamic environment with this prompt thing. The
+      ;; result is a procedure that takes a frame.
+      (% (call-with-values
+             (lambda ()
+               (abort
+                (lambda (k)
+                  ;; Call frame->stack-vector before reinstating the
+                  ;; continuation, so that we catch the %stacks fluid at
+                  ;; the time of capture.
+                  (lambda (frame)
+                    (k frame
+                       (frame->stack-vector
+                        (frame-previous frame)))))))
+           (lambda (from stack)
+             (format #t "~a~%" msg)
+             (let ((vals (frame-return-values from)))
+               (if (null? vals)
+                   (format #t "No return values.~%" msg)
+                   (begin
+                     (format #t "Return values:~%" msg)
+                     (for-each (lambda (x) (repl-print repl x)) vals))))
+             ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
+              #:debug (make-debug stack 0 msg))))))
+    (add-trap-at-frame-finish! cur resume-repl)
+    (throw 'quit)))
+
 (define-meta-command (tracepoint repl (form))
   "tracepoint PROCEDURE
 Add a tracepoint to PROCEDURE.
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 0e491b5..da42a37 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -32,7 +32,8 @@
   #:export (<debug>
             make-debug debug? debug-frames debug-index debug-error-message
             print-registers print-locals print-frame print-frames frame->module
-            stack->vector narrow-stack->vector))
+            stack->vector narrow-stack->vector
+            frame->stack-vector))
 
 ;; TODO:
 ;;
@@ -181,6 +182,21 @@
         (stack->vector narrowed)
         #()))) ; ? Can be the case for a tail-call to `throw' tho
 
+(define (frame->stack-vector frame)
+  (let ((tag (and (pair? (fluid-ref %stacks))
+                  (cdar (fluid-ref %stacks)))))
+    (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))))
 
 ;; (define (debug)
 ;;   (run-debugger
diff --git a/module/system/repl/error-handling.scm 
b/module/system/repl/error-handling.scm
index 72193a8..34a158f 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -72,13 +72,17 @@
                      ;; 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))
+             (error-msg (if trap-idx
+                            (format #f "Trap ~d: ~a" trap-idx trap-name)
+                            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")
+           (if trap-idx
+               (begin
+                 (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)))))
 
     (define (null-trap-handler frame trap-idx trap-name)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index c94b802..ffa66d5 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -28,7 +28,8 @@
             frame-binding-ref frame-binding-set!
             frame-source frame-call-representation
             frame-environment
-            frame-object-binding frame-object-name))
+            frame-object-binding frame-object-name
+            frame-return-values))
 
 (define (frame-bindings frame)
   (program-bindings-for-ip (frame-procedure frame)
@@ -149,3 +150,12 @@
 (define (frame-object-name frame obj)
   (cond ((frame-object-binding frame obj) => binding:name)
        (else #f)))
+
+;; Nota bene, only if frame is in a return context (i.e. in a
+;; pop-continuation hook dispatch).
+(define (frame-return-values frame)
+  (let* ((len (frame-num-locals frame))
+         (nvalues (frame-local-ref frame (1- len))))
+    (map (lambda (i)
+           (frame-local-ref frame (+ (- len nvalues) i)))
+         (iota nvalues))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 0c878e3..138d364 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -36,13 +36,6 @@
 ;; FIXME: this constant needs to go in system vm objcode
 (define *objcode-header-len* 8)
 
-(define (frame-return-values frame)
-  (let* ((len (frame-num-locals frame))
-         (nvalues (frame-local-ref frame (1- len))))
-    (map (lambda (i)
-           (frame-local-ref frame (+ (- len nvalues) i)))
-         (iota nvalues))))
-  
 (define (print-application frame depth width prefix)
   (format (current-error-port) "~a~a~v:@y\n"
           prefix (make-string depth #\|)
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index c67ea32..f45f981 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -38,7 +38,8 @@
 
             add-trap-at-procedure-call!
             add-trace-at-procedure-call!
-            add-trap-at-source-location!))
+            add-trap-at-source-location!
+            add-trap-at-frame-finish!))
 
 (define %default-trap-handler (make-fluid))
 
@@ -57,6 +58,7 @@
 (define-record <trap-state>
   (handler default-trap-handler)
   (next-idx 0)
+  (next-ephemeral-idx -1)
   (wrappers '()))
 
 (define (trap-wrapper<? t1 t2)
@@ -86,7 +88,8 @@
   (trap-wrapper-index wrapper))
 
 (define (remove-trap-wrapper! trap-state wrapper)
-  (delq wrapper (trap-state-wrappers trap-state)))
+  (set! (trap-state-wrappers trap-state)
+        (delq wrapper (trap-state-wrappers trap-state))))
 
 (define (trap-state->trace-level trap-state)
   (fold (lambda (wrapper level)
@@ -102,7 +105,7 @@
      ((null? wrappers)
       (warn "no wrapper found with index in trap-state" idx)
       #f)
-     ((= (trap-wrapper-index (car wrappers)) idx)
+     ((eqv? (trap-wrapper-index (car wrappers)) idx)
       (car wrappers))
      (else
       (lp (cdr wrappers))))))
@@ -112,6 +115,11 @@
     (set! (trap-state-next-idx trap-state) (1+ idx))
     idx))
 
+(define (next-ephemeral-index! trap-state)
+  (let ((idx (trap-state-next-ephemeral-idx trap-state)))
+    (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
+    idx))
+
 (define (handler-for-index trap-state idx)
   (lambda (frame)
     (let ((wrapper (wrapper-at-index trap-state idx))
@@ -121,6 +129,16 @@
                    (trap-wrapper-index wrapper)
                    (trap-wrapper-name wrapper))))))
 
+(define (ephemeral-handler-for-index trap-state idx handler)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx)))
+      (if wrapper
+          (begin
+            (if (trap-wrapper-enabled? wrapper)
+                (disable-trap-wrapper! wrapper))
+            (remove-trap-wrapper! trap-state wrapper)
+            (handler frame))))))
+
 
 
 ;;;
@@ -220,6 +238,20 @@
       idx #t trap
       (format #f "Breakpoint at ~a:~a" file user-line)))))
 
+;; handler := frame -> nothing
+(define* (add-trap-at-frame-finish! frame handler
+                                    #:optional (trap-state (the-trap-state)))
+  (let* ((idx (next-ephemeral-index! trap-state))
+         (trap (trap-frame-finish
+                frame
+                (ephemeral-handler-for-index trap-state idx handler)
+                (lambda (frame) (delete-trap! idx trap-state)))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Return from ~a" frame)))))
+
 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
   (let* ((idx (next-index! trap-state)))
     (add-trap-wrapper!
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 3b2a438..dfaedc5 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -268,7 +268,7 @@
           range))
 
 ;; Building on trap-instructions-in-procedure, we have
-;; trap-instructions-in-procedure.
+;; trap-at-procedure-ip-in-range.
 ;;
 (define* (trap-at-procedure-ip-in-range proc range handler
                                         #:key current-frame (vm (the-vm))


hooks/post-receive
-- 
GNU Guile