branch: elpa/buttercup
commit 6ef715f542df64a7ae539775910cbe122d4b66ea
Author: Ola Nilsson <ola.nils...@gmail.com>
Commit: Ola Nilsson <ola.nils...@gmail.com>
Use buttercup--mark-stackframe to mark the start of test code
The presense of a call to this function in a frame signals the start
of the interesting part of the backtrace.
The previous attempt to fix backtraces were insufficient. The result
was not the same for compiled and uncompiled code.
---
buttercup.el | 39 +++++++++++++++++++++++++++------------
tests/test-buttercup.el | 1 +
2 files changed, 28 insertions(+), 12 deletions(-)
diff --git a/buttercup.el b/buttercup.el
index 40efbd3..e6e4cb7 100644
--- a/buttercup.el
+++ b/buttercup.el
@@ -132,9 +132,16 @@ This macro knows three forms:
\(expect ARG)
Fail the current test if ARG is not true."
(let ((wrapped-args
- (mapcar (lambda (expr) `(lambda () (quote ,expr) ,expr)) args)))
+ (mapcar (lambda (expr) `(lambda ()
+ (quote ,expr)
+ (buttercup--mark-stackframe)
+ ,expr))
+ args)))
`(buttercup-expect
- (lambda () (quote ,arg) ,arg)
+ (lambda ()
+ (quote ,arg)
+ (buttercup--mark-stackframe)
+ ,arg)
,(or matcher :to-be-truthy)
,@wrapped-args)))
@@ -885,6 +892,7 @@ most probably including one or more calls to `expect'."
`(buttercup-it ,description
(lambda ()
(buttercup-with-converted-ert-signals
+ (buttercup--mark-stackframe)
,@body)))
`(buttercup-xit ,description)))
@@ -1921,14 +1929,16 @@ ARGS according to `debugger'."
(throw 'buttercup-debugger-continue
(list 'failed args (buttercup--backtrace))))
+(defalias 'buttercup--mark-stackframe 'ignore
+ "Marker to find where the backtrace start.")
+
(defun buttercup--backtrace ()
"Create a backtrace, a list of frames returned from `backtrace-frame'."
;; Read the backtrace frames from 0 (the closest) upward.
(cl-do* ((n 0 (1+ n))
(frame (backtrace-frame n) (backtrace-frame n))
(frame-list nil)
- (in-program-stack nil)
- (discard-frames nil))
+ (in-program-stack nil))
((not frame) frame-list)
;; discard frames until (and including) `buttercup--debugger', they
;; only contain buttercup code
@@ -1941,14 +1951,19 @@ ARGS according to `debugger'."
;; this is just the buttercup framework and not interesting for
;; users incorrect for testing buttercup. Some frames before the
;; function also have to be discarded
- (when (and in-program-stack
- (setq discard-frames
- (pcase (elt frame 1)
- (`buttercup--expr-and-value 2) ; matcher modified
with :not
- (`buttercup--apply-matcher 4) ; unmodified matcher
- (`buttercup--funcall 6))))
- (setq frame-list (nthcdr discard-frames frame-list))
- (cl-return frame-list))))
+ (cl-labels ((tree-find (key tree)
+ (cl-block tree-find
+ (while (consp tree)
+ (let ((elem (pop tree)))
+ (when (or (and (consp elem)
+ (tree-find key elem))
+ (eql key elem))
+ (cl-return-from tree-find t))))
+ (cl-return-from tree-find
+ (and tree (eql tree key))))))
+ (when (and in-program-stack (tree-find 'buttercup--mark-stackframe
frame))
+ (pop frame-list)
+ (cl-return frame-list)))))
(defun buttercup--format-stack-frame (frame &optional style)
"Format stack FRAME according to STYLE.
diff --git a/tests/test-buttercup.el b/tests/test-buttercup.el
index cdf493a..dfa26db 100644
--- a/tests/test-buttercup.el
+++ b/tests/test-buttercup.el
@@ -557,6 +557,7 @@ text properties using `ansi-color-apply'."
'(buttercup-it "description"
(lambda ()
(buttercup-with-converted-ert-signals
+ (buttercup--mark-stackframe)
body)))))
(it "without argument should expand to xit."
