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 <[email protected]> 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
