[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-946-g98451a3

[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=98451a38295b6f6bc5cd9764d3c5256f6cf2b0a9

The branch, wip-rtl has been updated
       via  98451a38295b6f6bc5cd9764d3c5256f6cf2b0a9 (commit)
      from  8506c754edeaa650e17bc694ec5d61717b76f93f (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 98451a38295b6f6bc5cd9764d3c5256f6cf2b0a9
Author: Andy Wingo <address@hidden>
Date:   Thu May 16 21:15:51 2013 +0200

    find-program-arities handles case-lambda appropriately
    
    * module/system/vm/debug.scm (read-sub-arities, find-program-arities):
      Handle case-lambda.
      (program-minimum-arity): Fix a bunch of bugs!

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

Summary of changes:
 module/system/vm/debug.scm |   25 ++++++++++++++++++++-----
 1 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c625fb7..0e87648 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -270,6 +270,17 @@
        (else
         (make-arity context base pos))))))
 
+(define (read-sub-arities context base outer-header-offset)
+  (let* ((bv (elf-bytes (debug-context-elf context)))
+         (headers-end (+ base (bytevector-u32-native-ref bv base)))
+         (low-pc (arity-low-pc* bv outer-header-offset))
+         (high-pc (arity-high-pc* bv outer-header-offset)))
+    (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+      (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+          (lp (+ pos arity-header-len)
+              (cons (make-arity context base pos) out))
+          (reverse out)))))
+
 (define* (find-program-arities addr #:optional
                                (context (find-debug-context addr)))
   (and=>
@@ -278,7 +289,11 @@
      (let* ((base (elf-section-offset sec))
             (first (find-first-arity context base addr)))
        ;; FIXME: Handle case-lambda arities.
-       (if first (list first) '())))))
+       (cond
+        ((not first) '())
+        ((arity-is-case-lambda? first)
+         (read-sub-arities context base (arity-header-offset first)))
+        (else (list first)))))))
 
 (define* (program-minimum-arity addr #:optional
                                 (context (find-debug-context addr)))
@@ -287,8 +302,8 @@
    (lambda (sec)
      (let* ((base (elf-section-offset sec))
             (first (find-first-arity context base addr)))
-       (if (arity-is-case-lambda?)
+       (if (arity-is-case-lambda? first)
            (list 0 0 #t) ;; FIXME: be more precise.
-           (list (arity-nreq arity)
-                 (arity-nopt arity)
-                 (arity-has-rest? arity)))))))
+           (list (arity-nreq first)
+                 (arity-nopt first)
+                 (arity-has-rest? first)))))))


hooks/post-receive
-- 
GNU Guile