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 base pmatch)
#:use-module (system vm program) #:use-module (system vm program)
#:use-module (system vm debug) #:use-module (system vm debug)
#:use-module (ice-9 match)
#:export (frame-bindings #:export (frame-bindings
frame-lookup-binding frame-lookup-binding
frame-binding-ref frame-binding-set! frame-binding-ref frame-binding-set!
@ -93,6 +94,21 @@
(frame-local-ref frame i) (frame-local-ref frame i)
;; Let's not error here, as we are called during backtraces. ;; 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 (cons
(or (and=> info program-debug-info-name) (or (and=> info program-debug-info-name)
(procedure-name closure) (procedure-name closure)
@ -107,25 +123,22 @@
((find-program-arity ip) ((find-program-arity ip)
=> (lambda (arity) => (lambda (arity)
;; case 1 ;; case 1
(let lp ((nreq (arity-nreq arity)) (reconstruct-arguments (arity-nreq arity)
(nopt (arity-nopt arity)) (arity-nopt arity)
(kw (arity-keyword-args arity)) (arity-keyword-args arity)
(has-rest? (arity-has-rest? arity)) (arity-has-rest? arity)
(i 1)) 1)))
(cond ((and (primitive? closure)
((positive? nreq) (program-arguments-alist closure ip))
(cons (local-ref i) => (lambda (args)
(lp (1- nreq) nopt kw has-rest? (1+ i)))) (match args
((positive? nopt) ((('required . req)
(cons (local-ref i) ('optional . opt)
(lp nreq (1- nopt) kw has-rest? (1+ i)))) ('keyword . kw)
((pair? kw) ('allow-other-keys? . _)
(cons* (caar kw) (local-ref (cdar kw)) ('rest . rest))
(lp nreq nopt (cdr kw) has-rest? (1+ i)))) ;; case 1
(has-rest? (reconstruct-arguments (length req) (length opt) kw rest 1)))))
(local-ref i))
(else
'())))))
(else (else
;; case 2 ;; case 2
(map local-ref (map local-ref

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

@ -19,6 +19,7 @@
:use-module (test-suite lib) :use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count)) :use-module ((srfi srfi-1) :select (unfold count))
:use-module ((system vm vm) :select (call-with-stack-overflow-handler)) :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 documentation)
:use-module (ice-9 local-eval)) :use-module (ice-9 local-eval))
@ -373,12 +374,9 @@
;; Create a stack with two primitive frames and make sure the ;; Create a stack with two primitive frames and make sure the
;; arguments are correct. ;; arguments are correct.
(let* ((stack (make-tagged-trimmed-stack tag '(#t))) (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
(call-list (map (lambda (frame) (call-list (map frame-call-representation (stack->frames stack))))
(cons (frame-procedure frame) (and (equal? (car call-list) '(make-stack #t))
(frame-arguments frame))) (pair? (member '(substring wrong type arg)
(stack->frames stack))))
(and (equal? (car call-list) `(,make-stack #t))
(pair? (member `(,substring wrong type arg)
(cdr call-list)))))) (cdr call-list))))))
(pass-if "inner trim with prompt tag" (pass-if "inner trim with prompt tag"