[Guile-commits] GNU Guile branch, master, updated. v2.1.0-933-gc271065

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

The branch, master has been updated
       via  c271065e542fc527313d5fb08ef0aaddabb42e72 (commit)
      from  67ddb7e264bbc53a9b121bb21dc521651a15b205 (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 c271065e542fc527313d5fb08ef0aaddabb42e72
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 15 21:47:46 2014 +0200

    Fix frame-call-representation for primitive applications
    
    * module/system/vm/frame.scm (frame-call-representation): Fix to work
      for primitives.
    
    * test-suite/tests/eval.test ("stacks"): Update expected result for
      substring.

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

Summary of changes:
 module/system/vm/frame.scm |   51 +++++++++++++++++++++++++++----------------
 test-suite/tests/eval.test |   10 +++-----
 2 files changed, 36 insertions(+), 25 deletions(-)

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index a573079..1fa25bc 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -22,6 +22,7 @@
   #:use-module (system base pmatch)
   #:use-module (system vm program)
   #:use-module (system vm debug)
+  #:use-module (ice-9 match)
   #:export (frame-bindings
             frame-lookup-binding
             frame-binding-ref frame-binding-set!
@@ -93,6 +94,21 @@
           (frame-local-ref frame i)
           ;; Let's not error here, as we are called during backtraces.
           '???))
+    (define (reconstruct-arguments nreq nopt kw has-rest? local)
+      (cond
+       ((positive? nreq)
+        (cons (local-ref local)
+              (reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local))))
+       ((positive? nopt)
+        (cons (local-ref local)
+              (reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local))))
+       ((pair? kw)
+        (cons* (caar kw) (local-ref (cdar kw))
+               (reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ 
local))))
+       (has-rest?
+        (local-ref local))
+       (else
+        '())))
     (cons
      (or (and=> info program-debug-info-name)
          (procedure-name closure)
@@ -107,25 +123,22 @@
       ((find-program-arity ip)
        => (lambda (arity)
             ;; case 1
-            (let lp ((nreq (arity-nreq arity))
-                     (nopt (arity-nopt arity))
-                     (kw (arity-keyword-args arity))
-                     (has-rest? (arity-has-rest? arity))
-                     (i 1))
-              (cond
-               ((positive? nreq)
-                (cons (local-ref i)
-                      (lp (1- nreq) nopt kw has-rest? (1+ i))))
-               ((positive? nopt)
-                (cons (local-ref i)
-                      (lp nreq (1- nopt) kw has-rest? (1+ i))))
-               ((pair? kw)
-                (cons* (caar kw) (local-ref (cdar kw))
-                       (lp nreq nopt (cdr kw) has-rest? (1+ i))))
-               (has-rest?
-                (local-ref i))
-               (else
-                '())))))
+            (reconstruct-arguments (arity-nreq arity)
+                                   (arity-nopt arity)
+                                   (arity-keyword-args arity)
+                                   (arity-has-rest? arity)
+                                   1)))
+      ((and (primitive? closure)
+            (program-arguments-alist closure ip))
+       => (lambda (args)
+            (match args
+              ((('required . req)
+                ('optional . opt)
+                ('keyword . kw)
+                ('allow-other-keys? . _)
+                ('rest . rest))
+               ;; case 1
+               (reconstruct-arguments (length req) (length opt) kw rest 1)))))
       (else
        ;; case 2
        (map local-ref
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 10d2669..fca3852 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -19,6 +19,7 @@
   :use-module (test-suite lib)
   :use-module ((srfi srfi-1) :select (unfold count))
   :use-module ((system vm vm) :select (call-with-stack-overflow-handler))
+  :use-module ((system vm frame) :select (frame-call-representation))
   :use-module (ice-9 documentation)
   :use-module (ice-9 local-eval))
 
@@ -373,12 +374,9 @@
     ;; Create a stack with two primitive frames and make sure the
     ;; arguments are correct.
     (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
-           (call-list (map (lambda (frame)
-                             (cons (frame-procedure frame)
-                                   (frame-arguments frame)))
-                           (stack->frames stack))))
-      (and (equal? (car call-list) `(,make-stack #t))
-           (pair? (member `(,substring wrong type arg)
+           (call-list (map frame-call-representation (stack->frames stack))))
+      (and (equal? (car call-list) '(make-stack #t))
+           (pair? (member '(substring wrong type arg)
                           (cdr call-list))))))
 
   (pass-if "inner trim with prompt tag"


hooks/post-receive
-- 
GNU Guile