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

Add tests for the stack inspection API.

Browse source 
* test-suite/tests/eval.test (stack->frames): New procedure.
  ("stacks"): New test prefix.
This commit is contained in:
Ludovic Courtès 2009-02-17 00:11:20 +01:00
parent 8455a73329
commit 5e07264f04
1 changed files with 64 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -17,6 +17,7 @@
(define-module (test-suite test-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
:use-module (ice-9 documentation))
@ -312,6 +313,68 @@
(%make-void-port "w"))
#t))))
;;;
;;; stacks
;;;
(define (stack->frames stack)
;; Return the list of frames comprising STACK.
(unfold (lambda (i)
(>= i (stack-length stack)))
(lambda (i)
(stack-ref stack i))
1+
0))
(with-test-prefix "stacks"
(with-debugging-evaluator
(pass-if "stack involving a subr"
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
(start-stack 'foo
(lazy-catch '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 ()
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(hashq-ref 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
hashq-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))))
;;;
;;; letrec init evaluation
;;;