mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Fix the argument list of gsubr stack frames.

Browse source 
This fixes a bug introduced in e20d7001c3
and reported by Neil.

* libguile/eval.i.c (CEVAL)[DEVAL]: Don't duplicate ARG1 in
  `debug.info->a.args' for gsubr stack frames.
  (scm_apply): Likewise.

* test-suite/tests/eval.test ("stacks")["arguments of a gsubr stack
  frame"]: New test.
This commit is contained in:
Ludovic Courtès 2009-10-02 10:26:30 +02:00
parent 187a43907f
commit 5b2f2c7552
2 changed files with 26 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/eval.i.c
View file

@ -1259,7 +1259,7 @@ dispatch:
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
case scm_tc7_gsubr:
#ifdef DEVAL
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.args = debug.info->a.args;
debug.info->a.proc = proc;
#endif
RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
@ -1896,7 +1896,7 @@ tail:
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = scm_cons (arg1, args);
debug.vect[0].a.args = args;
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif

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

@ -382,7 +382,30 @@
hashq-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))))
(= 1 result))))
(pass-if "arguments of a gsubr stack frame"
;; Create a stack with two gsubr frames and make sure the arguments are
;; correct.
(catch 'result
(lambda ()
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(substring 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(map (lambda (frame)
(cons (frame-procedure frame)
(frame-arguments frame)))
frames)))))))
(lambda (key result)
(and (equal? (car result) `(,make-stack #t))
(pair? (member `(,substring wrong type arg)
(cdr result)))))))))
;;;
;;; letrec init evaluation