112 lines
3.6 KiB
Scheme
112 lines
3.6 KiB
Scheme
(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
|
|
|
|
&knots-exception
|
|
make-knots-exception
|
|
knots-exception?
|
|
knots-exception-stack
|
|
|
|
print-backtrace-and-exception/knots))
|
|
|
|
(define (call-with-default-io-waiters thunk)
|
|
(parameterize
|
|
((current-read-waiter (@@ (ice-9 suspendable-ports)
|
|
default-read-waiter))
|
|
(current-write-waiter (@@ (ice-9 suspendable-ports)
|
|
default-write-waiter)))
|
|
(thunk)))
|
|
|
|
(define (wait-when-system-clock-behind)
|
|
(let ((start-of-the-year-2000 946684800))
|
|
(while (< (current-time)
|
|
start-of-the-year-2000)
|
|
(simple-format (current-error-port)
|
|
"warning: system clock potentially behind, waiting\n")
|
|
(sleep 20))))
|
|
|
|
;; Copied from (fibers web server)
|
|
(define (call-with-sigint thunk cvar)
|
|
(let ((handler #f))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(set! handler
|
|
(sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
|
|
thunk
|
|
(lambda ()
|
|
(if handler
|
|
;; restore Scheme handler, SIG_IGN or SIG_DFL.
|
|
(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?
|
|
(exception-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)))
|
|
(_
|
|
(make-stack #t))))
|
|
(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)))
|