diff options
Diffstat (limited to 'knots.scm')
| -rw-r--r-- | knots.scm | 72 |
1 files changed, 71 insertions, 1 deletions
@@ -1,11 +1,21 @@ (define-module (knots) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) #:use-module (ice-9 suspendable-ports) #:use-module (fibers conditions) + #:use-module (system repl debug) #:export (call-with-default-io-waiters wait-when-system-clock-behind - call-with-sigint)) + call-with-sigint + + &knots-exception + make-knots-exception + knots-exception? + knots-exception-stack + + print-backtrace-and-exception/knots)) (define (call-with-default-io-waiters thunk) (parameterize @@ -37,3 +47,63 @@ (sigaction SIGINT (car handler) (cdr handler)) ;; restore original C handler. (sigaction SIGINT #f)))))) + +(define &knots-exception + (make-exception-type '&knots-exception + &exception + '(stack))) + +(define make-knots-exception + (record-constructor &knots-exception)) + +(define knots-exception? + (record-predicate &knots-exception)) + +(define knots-exception-stack + (exception-accessor + &knots-exception + (record-accessor &knots-exception 'stack))) + +(define* (print-backtrace-and-exception/knots + exn + #:key (port (current-error-port))) + (let* ((stack (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))))) + (error-string + (call-with-output-string + (lambda (port) + (let ((knots-stacks + (map knots-exception-stack + (filter knots-exception? + (simple-exceptions exn))))) + + (let ((stack-vec + (stack->vector stack))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + 6)) + port + #:count (stack-length stack))) + (for-each + (lambda (stack) + (let ((stack-vec + (stack->vector stack))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + 3)) + port + #:count (stack-length stack)))) + knots-stacks) + (print-exception + port + (if (null? knots-stacks) + (stack-ref stack 1) + (stack-ref (last knots-stacks) 3)) + '%exception + (list exn))))))) + (display error-string port))) |