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
exn
#: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
(match (fluid-ref %stacks)
((stack-tag . prompt-tag)
@ -75,56 +127,25 @@
0 (and prompt-tag 1)))
(_
(make-stack #t))))
(stack-len
(stack-length stack))
(string-port
(open-output-string))
(error-string
(call-with-output-string
(lambda (port)
(let ((knots-stacks
(map knots-exception-stack
(filter knots-exception?
(simple-exceptions exn)))))
(with-exception-handler
(lambda (exn)
(display (get-output-string string-port)
port)
(close-output-port string-port)
(display "\n\n" port)
(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
(backtrace port)
(simple-format
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)))))))
"\nexception in print-backtrace-and-exception/knots: ~A\n"
exn)
(raise-exception exn))
(lambda ()
(get-string string-port stack)
(let ((str (get-output-string string-port)))
(close-output-port string-port)
str)))))
(display error-string port)))