From 5e07264f04be7d87414bf3a6b80aff96288cda40 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 17 Feb 2009 00:11:20 +0100
Subject: [PATCH] Add tests for the stack inspection API.

* test-suite/tests/eval.test (stack->frames): New procedure.
  ("stacks"): New test prefix.
---
 test-suite/tests/eval.test | 65 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 64 insertions(+), 1 deletion(-)

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index b6ddb7b06..5299b0406 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -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
 ;;;