summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/vm/frame.scm51
-rw-r--r--test-suite/tests/eval.test10
2 files changed, 36 insertions, 25 deletions
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index a57307948..1fa25bc3b 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 10d26690b..fca385278 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"