cbaines/guile-knots
1
Fork 0
Code Issues 1 Pull requests Activity Actions

Make print-backtrace-and-exception/knots more reliable

Browse source 
Catch failures in the Guile code for printing backtraces, and print
the partial backtrace, plus the backtrace of the exception that
happened.
This commit is contained in:
Christopher Baines 2026-01-09 15:31:54 +00:00
parent 4642f7c7d2
commit 991a5f6961
1 changed files with 70 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

119
knots.scm
View file

@ -67,6 +67,58 @@
(define* (print-backtrace-and-exception/knots (define* (print-backtrace-and-exception/knots
exn exn
#:key (port (current-error-port))) #:key (port (current-error-port)))
(define (get-string port stack)
(define stack-len
(stack-length stack))
(let ((knots-stacks
(map knots-exception-stack
(filter knots-exception?
(simple-exceptions exn)))))
(let* ((stack-vec
(stack->vector stack))
(stack-vec-length
(vector-length stack-vec)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
(if (< stack-vec-length 5)
0
4)))
port
#:count (stack-length stack)))
(for-each
(lambda (stack)
(let* ((stack-vec
(stack->vector stack))
(stack-vec-length
(vector-length stack-vec)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
(if (< stack-vec-length 4)
0
3)))
port
#:count (stack-length stack))))
knots-stacks)
(print-exception
port
(if (null? knots-stacks)
(stack-ref stack
(if (< stack-len 4)
stack-len
4))
(let* ((stack (last knots-stacks))
(stack-len (stack-length stack)))
(stack-ref stack
(if (< stack-len 3)
stack-len
3))))
'%exception
(list exn))))
(let* ((stack (let* ((stack
(match (fluid-ref %stacks) (match (fluid-ref %stacks)
((stack-tag . prompt-tag) ((stack-tag . prompt-tag)
@ -75,56 +127,25 @@
0 (and prompt-tag 1))) 0 (and prompt-tag 1)))
(_ (_
(make-stack #t)))) (make-stack #t))))
(stack-len (string-port
(stack-length stack)) (open-output-string))
(error-string (error-string
(call-with-output-string (with-exception-handler
(lambda (port) (lambda (exn)
(let ((knots-stacks (display (get-output-string string-port)
(map knots-exception-stack port)
(filter knots-exception? (close-output-port string-port)
(simple-exceptions exn))))) (display "\n\n" port)
(let* ((stack-vec (backtrace port)
(stack->vector stack)) (simple-format
(stack-vec-length
(vector-length stack-vec)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
(if (< stack-vec-length 5)
0
4)))
port
#:count (stack-length stack)))
(for-each
(lambda (stack)
(let* ((stack-vec
(stack->vector stack))
(stack-vec-length
(vector-length stack-vec)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
(if (< stack-vec-length 4)
0
3)))
port
#:count (stack-length stack))))
knots-stacks)
(print-exception
port port
(if (null? knots-stacks) "\nexception in print-backtrace-and-exception/knots: ~A\n"
(stack-ref stack exn)
(if (< stack-len 4) (raise-exception exn))
stack-len (lambda ()
4)) (get-string string-port stack)
(let* ((stack (last knots-stacks)) (let ((str (get-output-string string-port)))
(stack-len (stack-length stack))) (close-output-port string-port)
(stack-ref stack str)))))
(if (< stack-len 3)
stack-len
3))))
'%exception
(list exn)))))))
(display error-string port))) (display error-string port)))