diff --git a/knots.scm b/knots.scm index 2144596..e8e9690 100644 --- a/knots.scm +++ b/knots.scm @@ -105,8 +105,6 @@ wait on CVAR in a fiber to implement clean shutdown on Ctrl-C: (sigaction SIGINT #f)))))) (define (call-with-temporary-thread thunk) - "Run THUNK in a temporary thread and return its result to the -calling fiber." (let ((channel (make-channel))) (call-with-new-thread (lambda () diff --git a/knots/backtraces.scm b/knots/backtraces.scm index 7268311..a12ecb6 100644 --- a/knots/backtraces.scm +++ b/knots/backtraces.scm @@ -32,7 +32,9 @@ knots-exception? knots-exception-stack - print-backtrace-and-exception/knots)) + print-backtrace-and-exception/knots + + classify-stack-situation)) (define &knots-exception (make-exception-type '&knots-exception @@ -41,20 +43,14 @@ (define make-knots-exception (record-constructor &knots-exception)) -(set-procedure-property! make-knots-exception 'documentation - "Construct a @code{&knots-exception} with the given stack.") (define knots-exception? (exception-predicate &knots-exception)) -(set-procedure-property! knots-exception? 'documentation - "Return @code{#t} if OBJ is a @code{&knots-exception}.") (define knots-exception-stack (exception-accessor &knots-exception (record-accessor &knots-exception 'stack))) -(set-procedure-property! knots-exception-stack 'documentation - "Return the stack from a @code{&knots-exception}.") (define (backtrace-debug-mode?) (let ((val (getenv "KNOTS_BACKTRACE_DEBUG"))) @@ -228,34 +224,6 @@ (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) - "Print the backtrace and exception information from EXN to PORT. This -procedure captures the stack, so should be run before the stack is -unwound, so using @code{with-exception-handler} without -@code{#:unwind? #t}, the exception may need to then be re-raised and -handled in an outer exception handler. - -@example -(with-exception-handler - (lambda (exn) - ;; Recover from the exception - #f) - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (do-things)))) - #:unwind? #t) -@end example - -It's important to use @code{print-backtrace-and-exception/knots} for -displaying backtraces involving functionality from Guile Knots, since -the stack involved is potentially split across several fibers. The -stacks involved are attached to the exception, and this procedure -extracts this information out and assembles a backtrace including all -the code involved. -" (define (get-string out stack) (let* ((stack-vector (stack->vector stack)) (knots-stack-vectors diff --git a/knots/parallelism.scm b/knots/parallelism.scm index 393d78c..e78e6e2 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -326,10 +326,6 @@ write directly to @code{process-channel}." (make-parallelism-limiter-record resource-pool) parallelism-limiter? (resource-pool parallelism-limiter-resource-pool)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'parallelism-limiter?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") (define* (make-parallelism-limiter limit #:key (name "unnamed")) "Return a parallelism limiter that allows at most LIMIT concurrent @@ -344,7 +340,6 @@ time. Further fibers block until a slot becomes free. #:name name))) (define (destroy-parallelism-limiter parallelism-limiter) - "Destroy PARALLELISM-LIMITER, releasing its underlying resource pool." (destroy-resource-pool (parallelism-limiter-resource-pool parallelism-limiter))) @@ -359,8 +354,6 @@ currently available." (thunk)))) (define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) - "Evaluate EXP ... while holding a slot from PARALLELISM-LIMITER. -Syntactic sugar around @code{call-with-parallelism-limiter}." (call-with-parallelism-limiter parallelism-limiter (lambda () exp ...))) diff --git a/knots/promise.scm b/knots/promise.scm index 8d21441..b85fe64 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -39,10 +39,6 @@ (thunk fibers-promise-thunk) (values-box fibers-promise-values-box) (evaluated-condition fibers-promise-evaluated-condition)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'fibers-promise?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") (define (fibers-delay thunk) "Return a new fiber-aware promise that will evaluate THUNK when diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 5a8e2e0..f06a156 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -86,22 +86,6 @@ set-resource-pool-channel!) (destroy-condition resource-pool-destroy-condition) (configuration resource-pool-configuration)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'resource-pool?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'resource-pool-name)) - 'documentation - "Return the name of the resource pool.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'resource-pool-channel)) - 'documentation - "Return the channel used by the resource pool.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'resource-pool-configuration)) - 'documentation - "Return the configuration alist of the resource pool.") (set-record-type-printer! @@ -1293,16 +1277,12 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-timeout (record-accessor &resource-pool-timeout 'pool))) -(set-procedure-property! resource-pool-timeout-error-pool 'documentation - "Return the pool from a @code{&resource-pool-timeout} exception.") (define make-resource-pool-timeout-error (record-constructor &resource-pool-timeout)) (define resource-pool-timeout-error? (exception-predicate &resource-pool-timeout)) -(set-procedure-property! resource-pool-timeout-error? 'documentation - "Return @code{#t} if OBJ is a @code{&resource-pool-timeout} exception.") (define &resource-pool-too-many-waiters (make-exception-type '&recource-pool-too-many-waiters @@ -1313,23 +1293,17 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'pool))) -(set-procedure-property! resource-pool-too-many-waiters-error-pool 'documentation - "Return the pool from a @code{&resource-pool-too-many-waiters} exception.") (define resource-pool-too-many-waiters-error-waiters-count (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'waiters-count))) -(set-procedure-property! resource-pool-too-many-waiters-error-waiters-count 'documentation - "Return the waiters count from a @code{&resource-pool-too-many-waiters} exception.") (define make-resource-pool-too-many-waiters-error (record-constructor &resource-pool-too-many-waiters)) (define resource-pool-too-many-waiters-error? (exception-predicate &resource-pool-too-many-waiters)) -(set-procedure-property! resource-pool-too-many-waiters-error? 'documentation - "Return @code{#t} if OBJ is a @code{&resource-pool-too-many-waiters} exception.") (define &resource-pool-destroyed (make-exception-type '&recource-pool-destroyed @@ -1340,16 +1314,12 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-destroyed (record-accessor &resource-pool-destroyed 'pool))) -(set-procedure-property! resource-pool-destroyed-error-pool 'documentation - "Return the pool from a @code{&resource-pool-destroyed} exception.") (define make-resource-pool-destroyed-error (record-constructor &resource-pool-destroyed)) (define resource-pool-destroyed-error? (exception-predicate &resource-pool-destroyed)) -(set-procedure-property! resource-pool-destroyed-error? 'documentation - "Return @code{#t} if OBJ is a @code{&resource-pool-destroyed} exception.") (define &resource-pool-destroy-resource (make-exception-type '&recource-pool-destroy-resource @@ -1358,13 +1328,9 @@ receive @code{&resource-pool-destroyed}." (define make-resource-pool-destroy-resource-exception (record-constructor &resource-pool-destroy-resource)) -(set-procedure-property! make-resource-pool-destroy-resource-exception 'documentation - "Construct a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-destroy-resource-exception? (exception-predicate &resource-pool-destroy-resource)) -(set-procedure-property! resource-pool-destroy-resource-exception? 'documentation - "Return @code{#t} if OBJ is a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-default-timeout-handler (make-parameter #f)) @@ -1501,8 +1467,6 @@ available. Return the resource once PROC has returned." (apply values vals))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) - "Evaluate EXP ... with RESOURCE bound to a resource checked out from -POOL. Syntactic sugar around @code{call-with-resource-from-pool}." (call-with-resource-from-pool pool (lambda (resource) exp ...))) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index aa460de..f8c44b2 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -160,14 +160,6 @@ from there, or #f if that would be an empty string." thread-pool? (resource-pool thread-pool-resource-pool) (arguments-parameter thread-pool-arguments-parameter-accessor)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'thread-pool?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'thread-pool-resource-pool)) - 'documentation - "Return the underlying resource pool of the thread pool.") (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures @@ -178,29 +170,15 @@ from there, or #f if that would be an empty string." (current-procedures fixed-size-thread-pool-current-procedures) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) (threads fixed-size-thread-pool-threads)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-channel)) - 'documentation - "Return the channel of the fixed-size thread pool.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-current-procedures)) - 'documentation - "Return the current procedures vector of the fixed-size thread pool.") ;; Since both thread pool records have this field, use a procedure ;; than handles the appropriate accessor (define (thread-pool-arguments-parameter pool) - "Return the arguments parameter for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-arguments-parameter pool) (thread-pool-arguments-parameter-accessor pool))) (define (thread-pool-default-checkout-timeout pool) - "Return the default checkout timeout for POOL." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-default-checkout-timeout pool) (assq-ref (resource-pool-configuration @@ -219,13 +197,9 @@ from there, or #f if that would be an empty string." (exception-accessor &thread-pool-timeout-error (record-accessor &thread-pool-timeout-error 'pool))) -(set-procedure-property! thread-pool-timeout-error-pool 'documentation - "Return the pool from a @code{&thread-pool-timeout-error} exception.") (define thread-pool-timeout-error? (exception-predicate &thread-pool-timeout-error)) -(set-procedure-property! thread-pool-timeout-error? 'documentation - "Return @code{#t} if OBJ is a @code{&thread-pool-timeout-error} exception.") (define* (make-fixed-size-thread-pool size #:key diff --git a/knots/timeout.scm b/knots/timeout.scm index 37da65e..2df2ddd 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -95,8 +95,6 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-timeout-error? (exception-predicate &port-timeout-error)) -(set-procedure-property! port-timeout-error? 'documentation - "Return @code{#t} if OBJ is a @code{&port-timeout-error}.") (define &port-read-timeout-error (make-exception-type '&port-read-timeout-error @@ -108,8 +106,6 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-read-timeout-error? (exception-predicate &port-read-timeout-error)) -(set-procedure-property! port-read-timeout-error? 'documentation - "Return @code{#t} if OBJ is a @code{&port-read-timeout-error}.") (define &port-write-timeout-error (make-exception-type '&port-write-timeout-error @@ -121,8 +117,6 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-write-timeout-error? (exception-predicate &port-write-timeout-error)) -(set-procedure-property! port-write-timeout-error? 'documentation - "Return @code{#t} if OBJ is a @code{&port-write-timeout-error}.") (define (readable? port) "Test if PORT is readable." diff --git a/knots/web-server.scm b/knots/web-server.scm index 8b328e3..b51ca00 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -141,29 +141,23 @@ closes PORT, unless KEEP-ALIVE? is true." (define request-body-ended-prematurely-error? (exception-predicate &request-body-ended-prematurely)) -(set-procedure-property! request-body-ended-prematurely-error? 'documentation - "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.") -(define (request-body-port/knots request) - "Return an input port for reading the body of request REQUEST. -Handles chunked transfer encoding." +(define (request-body-port/knots r) (cond - ((member '(chunked) (request-transfer-encoding request)) - (make-chunked-input-port (request-port request) + ((member '(chunked) (request-transfer-encoding r)) + (make-chunked-input-port (request-port r) #:keep-alive? #t)) (else (let ((content-length - (request-content-length request))) + (request-content-length r))) (make-delimited-input-port - (request-port request) + (request-port r) content-length (lambda (bytes-read) (raise-exception (make-request-body-ended-prematurely-error bytes-read)))))))) (define (read-request-body/knots r) - "Read and return the full body of request R as a bytevector. -Handles chunked transfer encoding." (cond ((member '(chunked) (request-transfer-encoding r)) (get-bytevector-all @@ -305,8 +299,6 @@ on the procedure being called at any particular time." #f) (define (default-write-response-exception-handler exn request) - "Default handler for exceptions raised while writing an HTTP response. -Logs the error for REQUEST to the current error port." (if (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_write")) @@ -536,18 +528,6 @@ Logs the error for REQUEST to the current error port." web-server? (socket web-server-socket) (port web-server-port)) -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'web-server?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'web-server-socket)) - 'documentation - "Return the socket of the web server.") -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'web-server-port)) - 'documentation - "Return the port number of the web server.") (define* (run-knots-web-server handler #:key (host #f) diff --git a/tests/backtraces/stack-situation-fibers.scm b/tests/backtraces/stack-situation-fibers.scm index 0aef4c7..c1e9ec8 100644 --- a/tests/backtraces/stack-situation-fibers.scm +++ b/tests/backtraces/stack-situation-fibers.scm @@ -11,8 +11,7 @@ (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" - ((@@ (knots backtraces) - classify-stack-situation) + (classify-stack-situation (stack->vector stack)))) (primitive-exit 0)) (lambda () diff --git a/tests/backtraces/stack-situation-script.scm b/tests/backtraces/stack-situation-script.scm index 6fc944d..a21a8bd 100644 --- a/tests/backtraces/stack-situation-script.scm +++ b/tests/backtraces/stack-situation-script.scm @@ -8,8 +8,7 @@ (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" - ((@@ (knots backtraces) - classify-stack-situation) + (classify-stack-situation (stack->vector stack)))) (primitive-exit 0)) (lambda () diff --git a/tests/backtraces/stack-situation-unknown.scm b/tests/backtraces/stack-situation-unknown.scm index 920457b..e95c263 100644 --- a/tests/backtraces/stack-situation-unknown.scm +++ b/tests/backtraces/stack-situation-unknown.scm @@ -9,9 +9,7 @@ (lambda (exn) (let* ((stack (make-stack #t)) (stack-classification - ((@@ (knots backtraces) - classify-stack-situation) - (stack->vector stack)))) + (classify-stack-situation (stack->vector stack)))) (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" stack-classification) (primitive-exit 0)))