From 7ba77010ae98e675340a7ea22b400f0dcc20ef65 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 15 May 2025 09:25:30 +0100 Subject: [PATCH] Handle %stacks not being a pair Not sure when this would happen, but guard against it. --- knots.scm | 13 ++++++++----- knots/parallelism.scm | 42 +++++++++++++++++++++++------------------ knots/resource-pool.scm | 15 +++++++++------ knots/thread-pool.scm | 21 ++++++++++++--------- 4 files changed, 53 insertions(+), 38 deletions(-) diff --git a/knots.scm b/knots.scm index 8e31c6b..42f2af7 100644 --- a/knots.scm +++ b/knots.scm @@ -67,11 +67,14 @@ (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))))) + (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) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index ab398f8..f8b2b8b 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -52,15 +52,18 @@ (lambda () (with-exception-handler (lambda (exn) - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (let ((stack (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1)))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))))) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) (lambda () (call-with-values (lambda () @@ -255,15 +258,18 @@ (lambda () (with-exception-handler (lambda (exn) - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (let ((stack (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1)))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))))) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) (lambda () (call-with-values (lambda () diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 76c11e6..da52051 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -923,15 +923,18 @@ available. Return the resource once PROC has returned." (lambda () (with-exception-handler (lambda (exn) - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (let ((stack (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1)))) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) (raise-exception (make-exception exn - (make-knots-exception stack))))))) + (make-knots-exception stack))))) (lambda () (proc resource)))) #:unwind? #t)) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index f2f174e..14a8125 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -251,15 +251,18 @@ arguments of the thread pool procedure." proc) (with-exception-handler (lambda (exn) - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (let ((stack (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1)))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))))) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) (lambda () (call-with-values (lambda ()