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

eval.test work

Browse source 
* test-suite/tests/eval.test ("stacks"): Enable another test, fix to use
  with-throw-handler, and remove a duplicate test, now that there is no
  difference between subrs and gsubrs.
This commit is contained in:
Andy Wingo 2011-11-17 10:52:06 +01:00
parent 46d80cae08
commit 7f622b82a2
1 changed files with 42 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -330,40 +330,13 @@
0)) 0))
(with-test-prefix "stacks" (with-test-prefix "stacks"
(with-debugging-evaluator (pass-if "stack involving a primitive"
;; The primitive involving the error must appear exactly once on the
(pass-if "stack involving a subr" ;; stack.
;; The subr involving the error must appear exactly once on the stack.
(catch 'result (catch 'result
(lambda () (lambda ()
(throw 'unresolved)
(start-stack 'foo (start-stack 'foo
(lazy-catch 'wrong-type-arg (with-throw-handler 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(fluid-ref 'not-a-fluid))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
fluid-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))
(pass-if "stack involving a gsubr"
;; The gsubr involving the error must appear exactly once on the stack.
;; This is less obvious since gsubr application may require an
;; additional `SCM_APPLY ()' call, which should not be visible to the
;; application.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda () (lambda ()
;; Trigger a `wrong-type-arg' exception. ;; Trigger a `wrong-type-arg' exception.
(hashq-ref 'wrong 'type 'arg)) (hashq-ref 'wrong 'type 'arg))
@ -372,20 +345,19 @@
(frames (stack->frames stack))) (frames (stack->frames stack)))
(throw 'result (throw 'result
(count (lambda (frame) (count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame) (eq? (frame-procedure frame)
hashq-ref))) hashq-ref))
frames))))))) frames)))))))
(lambda (key result) (lambda (key result)
(= 1 result)))) (= 1 result))))
(pass-if "arguments of a gsubr stack frame" (pass-if "arguments of a primitive stack frame"
;; Create a stack with two gsubr frames and make sure the arguments are ;; Create a stack with two primitive frames and make sure the
;; correct. ;; arguments are correct.
(catch 'result (catch 'result
(lambda () (lambda ()
(start-stack 'foo (start-stack 'foo
(lazy-catch 'wrong-type-arg (with-throw-handler 'wrong-type-arg
(lambda () (lambda ()
;; Trigger a `wrong-type-arg' exception. ;; Trigger a `wrong-type-arg' exception.
(substring 'wrong 'type 'arg)) (substring 'wrong 'type 'arg))
@ -400,7 +372,7 @@
(lambda (key result) (lambda (key result)
(and (equal? (car result) `(,make-stack #t)) (and (equal? (car result) `(,make-stack #t))
(pair? (member `(,substring wrong type arg) (pair? (member `(,substring wrong type arg)
(cdr result))))))))) (cdr result))))))))
;;; ;;;
;;; letrec init evaluation ;;; letrec init evaluation