mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

Fix frame-call-representation for primitive applications

Browse source 
* module/system/vm/frame.scm (frame-call-representation): Fix to work
  for primitives.

* test-suite/tests/eval.test ("stacks"): Update expected result for
  substring.
This commit is contained in:
Andy Wingo 2014-04-15 21:47:46 +02:00
parent 67ddb7e264
commit c271065e54
2 changed files with 36 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

51
module/system/vm/frame.scm
View file

@ -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

10
test-suite/tests/eval.test
View file

@ -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"