318 lines
13 KiB
Scheme
318 lines
13 KiB
Scheme
(use-modules (srfi srfi-1)
|
|
(srfi srfi-13)
|
|
(ice-9 popen)
|
|
(ice-9 rdelim)
|
|
(ice-9 match))
|
|
|
|
(define (run-backtrace-script file)
|
|
(let* ((pipe (open-pipe (string-append "./test-env guile " file " 2>&1")
|
|
OPEN_READ))
|
|
(output (read-string pipe)))
|
|
(close-pipe pipe)
|
|
output))
|
|
|
|
(define (read-backtrace-entry-annotation script keyword)
|
|
;; Scan SCRIPT line by line and return the annotation for the expected
|
|
;; backtrace entry matching KEYWORD (e.g. "FIRST" or "LAST"), or #f if
|
|
;; none is found.
|
|
;;
|
|
;; Two forms are recognised:
|
|
;;
|
|
;; ; KEYWORD BACKTRACE ENTRY HERE
|
|
;; — placed inline on a code line. Returns ('here LINE COL) where LINE
|
|
;; is the 1-based line number and COL is the 0-based column of the
|
|
;; first non-space character on that line.
|
|
;;
|
|
;; ; KEYWORD BACKTRACE ENTRY: STRING
|
|
;; — STRING is a literal substring expected to appear in the output.
|
|
;; Returns ('string STRING).
|
|
(let ((here-marker (string-append keyword " BACKTRACE ENTRY HERE"))
|
|
(string-marker (string-append keyword " BACKTRACE ENTRY: ")))
|
|
(call-with-input-file script
|
|
(lambda (port)
|
|
(let loop ((line (read-line port)) (line-num 1))
|
|
(cond
|
|
((eof-object? line) #f)
|
|
((string-contains line here-marker)
|
|
(let ((col (string-index line (lambda (c) (not (char=? c #\space))))))
|
|
(list 'here line-num col)))
|
|
((string-contains line string-marker)
|
|
(let* ((idx (+ (string-contains line string-marker)
|
|
(string-length string-marker)))
|
|
(content (string-trim-right (substring line idx))))
|
|
(list 'string content)))
|
|
(else (loop (read-line port) (+ line-num 1)))))))))
|
|
|
|
(define (frame-line? line)
|
|
;; Return #t if LINE looks like a backtrace frame line: leading whitespace
|
|
;; followed by digits:digits (LINE:COL).
|
|
(and (> (string-length line) 0)
|
|
(let* ((stripped (string-trim line))
|
|
(colon (string-index stripped #\:)))
|
|
(and colon
|
|
(> colon 0)
|
|
(string-every char-set:digit stripped 0 colon)))))
|
|
|
|
(define (extract-frame-lines output)
|
|
;; Return all backtrace frame lines before "ERROR:" in OUTPUT.
|
|
(let* ((error-pos (string-contains output "\nERROR:"))
|
|
(before-error (if error-pos
|
|
(substring output 0 error-pos)
|
|
output)))
|
|
(filter frame-line? (string-split before-error #\newline))))
|
|
|
|
(define (innermost-frame-line output)
|
|
;; Return the last backtrace frame line before "ERROR:" in OUTPUT, or #f.
|
|
(let ((frame-lines (extract-frame-lines output)))
|
|
(if (null? frame-lines) #f (last frame-lines))))
|
|
|
|
(define (outermost-frame-line output)
|
|
;; Return the first backtrace frame line before "ERROR:" in OUTPUT, or #f.
|
|
(let ((frame-lines (extract-frame-lines output)))
|
|
(if (null? frame-lines) #f (car frame-lines))))
|
|
|
|
;;; Assertions
|
|
|
|
(define current-test-fail-count 0)
|
|
|
|
(define (expect! label ok? detail)
|
|
;; Print one expectation line; record a failure if not ok.
|
|
(if ok?
|
|
(format #t " PASS ~a~%" label)
|
|
(begin
|
|
(set! current-test-fail-count (+ current-test-fail-count 1))
|
|
(format #t " FAIL ~a~% ~a~%" label detail))))
|
|
|
|
(define (assert-output-contains output expected)
|
|
(expect! (format #f "output contains ~s" expected)
|
|
(string-contains output expected)
|
|
"not found in output"))
|
|
|
|
(define (assert-output-excludes output unexpected)
|
|
(expect! (format #f "output excludes ~s" unexpected)
|
|
(not (string-contains output unexpected))
|
|
"unexpectedly found in output"))
|
|
|
|
(define (assert-backtrace-entry output script keyword frame-line-proc)
|
|
(let ((annotation (read-backtrace-entry-annotation script keyword))
|
|
(frame (frame-line-proc output)))
|
|
(when annotation
|
|
(match annotation
|
|
(('here line col)
|
|
(let ((expected (string-append (number->string line) ":"
|
|
(number->string col))))
|
|
(expect! (format #f "~a backtrace entry ~a" keyword expected)
|
|
(and frame (string-contains frame expected))
|
|
(format #f "got ~s" (or frame "(none)")))))
|
|
(('string content)
|
|
(expect! (format #f "~a backtrace entry ~s" keyword content)
|
|
(string-contains output content)
|
|
"not found in output"))))))
|
|
|
|
(define (assert-first-backtrace-entry output script)
|
|
(assert-backtrace-entry output script "FIRST" outermost-frame-line))
|
|
|
|
(define (assert-last-backtrace-entry output script)
|
|
(assert-backtrace-entry output script "LAST" innermost-frame-line))
|
|
|
|
;;; Test runner
|
|
|
|
(define pass-count 0)
|
|
(define fail-count 0)
|
|
|
|
(define (run-test name thunk)
|
|
(set! current-test-fail-count 0)
|
|
(format #t "~%~a~%" name)
|
|
(catch #t
|
|
thunk
|
|
(lambda (key . args)
|
|
(set! current-test-fail-count (+ current-test-fail-count 1))
|
|
(format #t " ERROR unexpected exception: ~s~%" (cons key args))))
|
|
(if (zero? current-test-fail-count)
|
|
(set! pass-count (+ pass-count 1))
|
|
(set! fail-count (+ fail-count 1))))
|
|
|
|
;;; Tests
|
|
|
|
(run-test "plain-exception"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/plain-exception.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\""))))
|
|
|
|
(run-test "triple-with-exception-handler"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/triple-with-exception-handler.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\""))))
|
|
|
|
(run-test "wrapped-exception"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/wrapped-exception.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"wrapped error message\""))))
|
|
|
|
(run-test "temporary-thread"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/temporary-thread.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from temporary thread\""))))
|
|
|
|
(run-test "fibers-map"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/fibers-map.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-map\""))))
|
|
|
|
(run-test "call-with-resource-from-pool"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/call-with-resource-from-pool.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-resource-from-pool\""))))
|
|
|
|
;; Two knots stacks are printed (one per fiber boundary); ERROR: appears
|
|
;; once at the end after both frame blocks.
|
|
(run-test "call-with-cached-connection"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/call-with-cached-connection.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-cached-connection\""))))
|
|
|
|
(run-test "fibers-force"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/fibers-force.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-force\""))))
|
|
|
|
(run-test "call-with-thread"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/call-with-thread.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-thread\""))))
|
|
|
|
;; Nested fibers-map: user frames that survive fiber boundaries appear;
|
|
;; intermediate functions (one-deep, two-deep, three-deep) are lost at
|
|
;; their respective boundaries because fibers-map yields before the
|
|
;; exception propagates back. knots/parallelism.scm and srfi frames
|
|
;; appear as call-path context between the surviving user frames.
|
|
(run-test "nested-parallelism"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/nested-parallelism.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"deeply nested error ~S\"")
|
|
(assert-output-contains output "(run-work)")
|
|
(assert-output-contains output "(process-batch _)")
|
|
(assert-output-contains output "(deeply-nested _)")
|
|
(assert-output-excludes output "In fibers"))))
|
|
|
|
(run-test "guile-error-in-thread"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/guile-error-in-thread.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"\n 3. &message: \"Wrong type argument in position ~A: ~S\"\n 4. &irritants: (1 a)"))))
|
|
|
|
;; sort is a C function and appears as "In unknown file:" between the user frames.
|
|
(run-test "guile-error-deep-in-thread"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/guile-error-deep-in-thread.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"")
|
|
(assert-output-contains output "(do-sort)")
|
|
(assert-output-contains output "In unknown file:")
|
|
(assert-output-contains output "(sort (1 2 3)")
|
|
(assert-output-excludes output "In knots/")
|
|
(assert-output-excludes output "In srfi/"))))
|
|
|
|
;; The error fires inside ice-9/vlist.scm (vlist-fold passed a non-vlist),
|
|
;; so vlist-fold appears as the innermost frame and ice-9/vlist.scm frames
|
|
;; appear between the user frames.
|
|
(run-test "vhash-fold"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/vhash-fold.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &assertion-failure\n 2. &origin: #f")
|
|
(assert-output-contains output "(do-fold)")
|
|
(assert-output-contains output "In ice-9/vlist.scm:")
|
|
(assert-output-contains output "(vlist-fold"))))
|
|
|
|
;; do-fold calls vhash-fold in non-tail position so its frame is preserved.
|
|
;; ice-9/vlist.scm frames appear between the user frames, as in vhash-fold.
|
|
(run-test "vhash-fold-in-thread"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/vhash-fold-in-thread.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-first-backtrace-entry output script)
|
|
(assert-last-backtrace-entry output script)
|
|
(assert-output-contains output
|
|
"ERROR:\n 1. &assertion-failure\n 2. &origin: #f")
|
|
(assert-output-contains output "(do-fold)")
|
|
(assert-output-contains output "In ice-9/vlist.scm:")
|
|
(assert-output-contains output "(vlist-fold")
|
|
(assert-output-excludes output "In knots/"))))
|
|
|
|
(run-test "stack-situation-script"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/stack-situation-script.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-output-contains output "situation: script"))))
|
|
|
|
(run-test "stack-situation-fibers"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/stack-situation-fibers.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-output-contains output "situation: run-fibers"))))
|
|
|
|
(run-test "stack-situation-unknown"
|
|
(lambda ()
|
|
(let* ((script "tests/backtraces/stack-situation-unknown.scm")
|
|
(output (run-backtrace-script script)))
|
|
(assert-output-contains output "situation: unknown"))))
|
|
|
|
;;; Summary
|
|
|
|
(newline)
|
|
(if (zero? fail-count)
|
|
(format #t "All ~a scripts passed.~%" pass-count)
|
|
(format #t "~a of ~a scripts had failures.~%" fail-count (+ pass-count fail-count)))
|
|
|
|
(when (> fail-count 0)
|
|
(primitive-exit 1))
|