guile-knots/tests/backtraces.scm

(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))